Theory General
section ‹General Utilities›
theory General
imports Polynomials.Utils
begin
text ‹A couple of general-purpose functions and lemmas, mainly related to lists.›
subsection ‹Lists›
lemma distinct_reorder: "distinct (xs @ (y # ys)) = distinct (y # (xs @ ys))" by auto
lemma set_reorder: "set (xs @ (y # ys)) = set (y # (xs @ ys))" by simp
lemma distinctI:
assumes "⋀i j. i < j ⟹ i < length xs ⟹ j < length xs ⟹ xs ! i ≠ xs ! j"
shows "distinct xs"
using assms
proof (induct xs)
case Nil
show ?case by simp
next
case (Cons x xs)
show ?case
proof (simp, intro conjI, rule)
assume "x ∈ set xs"
then obtain j where "j < length xs" and "x = xs ! j" by (metis in_set_conv_nth)
hence "Suc j < length (x # xs)" by simp
have "(x # xs) ! 0 ≠ (x # xs) ! (Suc j)" by (rule Cons(2), simp, simp, fact)
thus False by (simp add: ‹x = xs ! j›)
next
show "distinct xs"
proof (rule Cons(1))
fix i j
assume "i < j" and "i < length xs" and "j < length xs"
hence "Suc i < Suc j" and "Suc i < length (x # xs)" and "Suc j < length (x # xs)" by simp_all
hence "(x # xs) ! (Suc i) ≠ (x # xs) ! (Suc j)" by (rule Cons(2))
thus "xs ! i ≠ xs ! j" by simp
qed
qed
qed
lemma filter_nth_pairE:
assumes "i < j" and "i < length (filter P xs)" and "j < length (filter P xs)"
obtains i' j' where "i' < j'" and "i' < length xs" and "j' < length xs"
and "(filter P xs) ! i = xs ! i'" and "(filter P xs) ! j = xs ! j'"
using assms
proof (induct xs arbitrary: i j thesis)
case Nil
from Nil(3) show ?case by simp
next
case (Cons x xs)
let ?ys = "filter P (x # xs)"
show ?case
proof (cases "P x")
case True
hence *: "?ys = x # (filter P xs)" by simp
from ‹i < j› obtain j0 where j: "j = Suc j0" using lessE by blast
have len_ys: "length ?ys = Suc (length (filter P xs))" and ys_j: "?ys ! j = (filter P xs) ! j0"
by (simp only: * length_Cons, simp only: j * nth_Cons_Suc)
from Cons(5) have "j0 < length (filter P xs)" unfolding len_ys j by auto
show ?thesis
proof (cases "i = 0")
case True
from ‹j0 < length (filter P xs)› obtain j' where "j' < length xs" and **: "(filter P xs) ! j0 = xs ! j'"
by (metis (no_types, lifting) in_set_conv_nth mem_Collect_eq nth_mem set_filter)
have "0 < Suc j'" by simp
thus ?thesis
by (rule Cons(2), simp, simp add: ‹j' < length xs›, simp only: True * nth_Cons_0,
simp only: ys_j nth_Cons_Suc **)
next
case False
then obtain i0 where i: "i = Suc i0" using lessE by blast
have ys_i: "?ys ! i = (filter P xs) ! i0" by (simp only: i * nth_Cons_Suc)
from Cons(3) have "i0 < j0" by (simp add: i j)
from Cons(4) have "i0 < length (filter P xs)" unfolding len_ys i by auto
from _ ‹i0 < j0› this ‹j0 < length (filter P xs)› obtain i' j'
where "i' < j'" and "i' < length xs" and "j' < length xs"
and i': "filter P xs ! i0 = xs ! i'" and j': "filter P xs ! j0 = xs ! j'"
by (rule Cons(1))
from ‹i' < j'› have "Suc i' < Suc j'" by simp
thus ?thesis
by (rule Cons(2), simp add: ‹i' < length xs›, simp add: ‹j' < length xs›,
simp only: ys_i nth_Cons_Suc i', simp only: ys_j nth_Cons_Suc j')
qed
next
case False
hence *: "?ys = filter P xs" by simp
with Cons(4) Cons(5) have "i < length (filter P xs)" and "j < length (filter P xs)" by simp_all
with _ ‹i < j› obtain i' j' where "i' < j'" and "i' < length xs" and "j' < length xs"
and i': "filter P xs ! i = xs ! i'" and j': "filter P xs ! j = xs ! j'"
by (rule Cons(1))
from ‹i' < j'› have "Suc i' < Suc j'" by simp
thus ?thesis
by (rule Cons(2), simp add: ‹i' < length xs›, simp add: ‹j' < length xs›,
simp only: * nth_Cons_Suc i', simp only: * nth_Cons_Suc j')
qed
qed
lemma distinct_filterI:
assumes "⋀i j. i < j ⟹ i < length xs ⟹ j < length xs ⟹ P (xs ! i) ⟹ P (xs ! j) ⟹ xs ! i ≠ xs ! j"
shows "distinct (filter P xs)"
proof (rule distinctI)
fix i j::nat
assume "i < j" and "i < length (filter P xs)" and "j < length (filter P xs)"
then obtain i' j' where "i' < j'" and "i' < length xs" and "j' < length xs"
and i: "(filter P xs) ! i = xs ! i'" and j: "(filter P xs) ! j = xs ! j'" by (rule filter_nth_pairE)
from ‹i' < j'› ‹i' < length xs› ‹j' < length xs› show "(filter P xs) ! i ≠ (filter P xs) ! j" unfolding i j
proof (rule assms)
from ‹i < length (filter P xs)› show "P (xs ! i')" unfolding i[symmetric] using nth_mem by force
next
from ‹j < length (filter P xs)› show "P (xs ! j')" unfolding j[symmetric] using nth_mem by force
qed
qed
lemma set_zip_map: "set (zip (map f xs) (map g xs)) = (λx. (f x, g x)) ` (set xs)"
proof -
have "{(map f xs ! i, map g xs ! i) |i. i < length xs} = {(f (xs ! i), g (xs ! i)) |i. i < length xs}"
proof (rule Collect_eqI, rule, elim exE conjE, intro exI conjI, simp add: map_nth, assumption,
elim exE conjE, intro exI)
fix x i
assume "x = (f (xs ! i), g (xs ! i))" and "i < length xs"
thus "x = (map f xs ! i, map g xs ! i) ∧ i < length xs" by (simp add: map_nth)
qed
also have "... = (λx. (f x, g x)) ` {xs ! i | i. i < length xs}" by blast
finally show "set (zip (map f xs) (map g xs)) = (λx. (f x, g x)) ` (set xs)"
by (simp add: set_zip set_conv_nth[symmetric])
qed
lemma set_zip_map1: "set (zip (map f xs) xs) = (λx. (f x, x)) ` (set xs)"
proof -
have "set (zip (map f xs) (map id xs)) = (λx. (f x, id x)) ` (set xs)" by (rule set_zip_map)
thus ?thesis by simp
qed
lemma set_zip_map2: "set (zip xs (map f xs)) = (λx. (x, f x)) ` (set xs)"
proof -
have "set (zip (map id xs) (map f xs)) = (λx. (id x, f x)) ` (set xs)" by (rule set_zip_map)
thus ?thesis by simp
qed
lemma UN_upt: "(⋃i∈{0..<length xs}. f (xs ! i)) = (⋃x∈set xs. f x)"
by (metis image_image map_nth set_map set_upt)
lemma sum_list_zeroI':
assumes "⋀i. i < length xs ⟹ xs ! i = 0"
shows "sum_list xs = 0"
proof (rule sum_list_zeroI, rule, simp)
fix x
assume "x ∈ set xs"
then obtain i where "i < length xs" and "x = xs ! i" by (metis in_set_conv_nth)
from this(1) show "x = 0" unfolding ‹x = xs ! i› by (rule assms)
qed
lemma sum_list_map2_plus:
assumes "length xs = length ys"
shows "sum_list (map2 (+) xs ys) = sum_list xs + sum_list (ys::'a::comm_monoid_add list)"
using assms
proof (induct rule: list_induct2)
case Nil
show ?case by simp
next
case (Cons x xs y ys)
show ?case by (simp add: Cons(2) ac_simps)
qed
lemma sum_list_eq_nthI:
assumes "i < length xs" and "⋀j. j < length xs ⟹ j ≠ i ⟹ xs ! j = 0"
shows "sum_list xs = xs ! i"
using assms
proof (induct xs arbitrary: i)
case Nil
from Nil(1) show ?case by simp
next
case (Cons x xs)
have *: "xs ! j = 0" if "j < length xs" and "Suc j ≠ i" for j
proof -
have "xs ! j = (x # xs) ! (Suc j)" by simp
also have "... = 0" by (rule Cons(3), simp add: ‹j < length xs›, fact)
finally show ?thesis .
qed
show ?case
proof (cases i)
case 0
have "sum_list xs = 0" by (rule sum_list_zeroI', erule *, simp add: 0)
with 0 show ?thesis by simp
next
case (Suc k)
with Cons(2) have "k < length xs" by simp
hence "sum_list xs = xs ! k"
proof (rule Cons(1))
fix j
assume "j < length xs"
assume "j ≠ k"
hence "Suc j ≠ i" by (simp add: Suc)
with ‹j < length xs› show "xs ! j = 0" by (rule *)
qed
moreover have "x = 0"
proof -
have "x = (x # xs) ! 0" by simp
also have "... = 0" by (rule Cons(3), simp_all add: Suc)
finally show ?thesis .
qed
ultimately show ?thesis by (simp add: Suc)
qed
qed
subsubsection ‹‹max_list››
fun (in ord) max_list :: "'a list ⇒ 'a" where
"max_list (x # xs) = (case xs of [] ⇒ x | _ ⇒ max x (max_list xs))"
context linorder
begin
lemma max_list_Max: "xs ≠ [] ⟹ max_list xs = Max (set xs)"
by (induct xs rule: induct_list012, auto)
lemma max_list_ge:
assumes "x ∈ set xs"
shows "x ≤ max_list xs"
proof -
from assms have "xs ≠ []" by auto
from finite_set assms have "x ≤ Max (set xs)" by (rule Max_ge)
also from ‹xs ≠ []› have "Max (set xs) = max_list xs" by (rule max_list_Max[symmetric])
finally show ?thesis .
qed
lemma max_list_boundedI:
assumes "xs ≠ []" and "⋀x. x ∈ set xs ⟹ x ≤ a"
shows "max_list xs ≤ a"
proof -
from assms(1) have "set xs ≠ {}" by simp
from assms(1) have "max_list xs = Max (set xs)" by (rule max_list_Max)
also from finite_set ‹set xs ≠ {}› assms(2) have "… ≤ a" by (rule Max.boundedI)
finally show ?thesis .
qed
end
subsubsection ‹‹insort_wrt››
primrec insort_wrt :: "('c ⇒ 'c ⇒ bool) ⇒ 'c ⇒ 'c list ⇒ 'c list" where
"insort_wrt _ x [] = [x]" |
"insort_wrt r x (y # ys) =
(if r x y then (x # y # ys) else y # (insort_wrt r x ys))"
lemma insort_wrt_not_Nil [simp]: "insort_wrt r x xs ≠ []"
by (induct xs, simp_all)
lemma length_insort_wrt [simp]: "length (insort_wrt r x xs) = Suc (length xs)"
by (induct xs, simp_all)
lemma set_insort_wrt [simp]: "set (insort_wrt r x xs) = insert x (set xs)"
by (induct xs, auto)
lemma sorted_wrt_insort_wrt_imp_sorted_wrt:
assumes "sorted_wrt r (insort_wrt s x xs)"
shows "sorted_wrt r xs"
using assms
proof (induct xs)
case Nil
show ?case by simp
next
case (Cons a xs)
show ?case
proof (cases "s x a")
case True
with Cons.prems have "sorted_wrt r (x # a # xs)" by simp
thus ?thesis by simp
next
case False
with Cons(2) have "sorted_wrt r (a # (insort_wrt s x xs))" by simp
hence *: "(∀y∈set xs. r a y)" and "sorted_wrt r (insort_wrt s x xs)"
by (simp_all)
from this(2) have "sorted_wrt r xs" by (rule Cons(1))
with * show ?thesis by (simp)
qed
qed
lemma sorted_wrt_imp_sorted_wrt_insort_wrt:
assumes "transp r" and "⋀a. r a x ∨ r x a" and "sorted_wrt r xs"
shows "sorted_wrt r (insort_wrt r x xs)"
using assms(3)
proof (induct xs)
case Nil
show ?case by simp
next
case (Cons a xs)
show ?case
proof (cases "r x a")
case True
with Cons(2) assms(1) show ?thesis by (auto dest: transpD)
next
case False
with assms(2) have "r a x" by blast
from Cons(2) have *: "(∀y∈set xs. r a y)" and "sorted_wrt r xs"
by (simp_all)
from this(2) have "sorted_wrt r (insort_wrt r x xs)" by (rule Cons(1))
with ‹r a x› * show ?thesis by (simp add: False)
qed
qed
corollary sorted_wrt_insort_wrt:
assumes "transp r" and "⋀a. r a x ∨ r x a"
shows "sorted_wrt r (insort_wrt r x xs) ⟷ sorted_wrt r xs" (is "?l ⟷ ?r")
proof
assume ?l
then show ?r by (rule sorted_wrt_insort_wrt_imp_sorted_wrt)
next
assume ?r
with assms show ?l by (rule sorted_wrt_imp_sorted_wrt_insort_wrt)
qed
subsubsection ‹‹diff_list› and ‹insert_list››
definition diff_list :: "'a list ⇒ 'a list ⇒ 'a list" (infixl "--" 65)
where "diff_list xs ys = fold removeAll ys xs"
lemma set_diff_list: "set (xs -- ys) = set xs - set ys"
by (simp only: diff_list_def, induct ys arbitrary: xs, auto)
lemma diff_list_disjoint: "set ys ∩ set (xs -- ys) = {}"
unfolding set_diff_list by (rule Diff_disjoint)
lemma subset_append_diff_cancel:
assumes "set ys ⊆ set xs"
shows "set (ys @ (xs -- ys)) = set xs"
by (simp only: set_append set_diff_list Un_Diff_cancel, rule Un_absorb1, fact)
definition insert_list :: "'a ⇒ 'a list ⇒ 'a list"
where "insert_list x xs = (if x ∈ set xs then xs else x # xs)"
lemma set_insert_list: "set (insert_list x xs) = insert x (set xs)"
by (auto simp add: insert_list_def)
subsubsection ‹‹remdups_wrt››
primrec remdups_wrt :: "('a ⇒ 'b) ⇒ 'a list ⇒ 'a list" where
remdups_wrt_base: "remdups_wrt _ [] = []" |
remdups_wrt_rec: "remdups_wrt f (x # xs) = (if f x ∈ f ` set xs then remdups_wrt f xs else x # remdups_wrt f xs)"
lemma set_remdups_wrt: "f ` set (remdups_wrt f xs) = f ` set xs"
proof (induct xs)
case Nil
show ?case unfolding remdups_wrt_base ..
next
case (Cons a xs)
show ?case unfolding remdups_wrt_rec
proof (simp only: split: if_splits, intro conjI, intro impI)
assume "f a ∈ f ` set xs"
have "f ` set (a # xs) = insert (f a) (f ` set xs)" by simp
have "f ` set (remdups_wrt f xs) = f ` set xs" by fact
also from ‹f a ∈ f ` set xs› have "... = insert (f a) (f ` set xs)" by (simp add: insert_absorb)
also have "... = f ` set (a # xs)" by simp
finally show "f ` set (remdups_wrt f xs) = f ` set (a # xs)" .
qed (simp add: Cons.hyps)
qed
lemma subset_remdups_wrt: "set (remdups_wrt f xs) ⊆ set xs"
by (induct xs, auto)
lemma remdups_wrt_distinct_wrt:
assumes "x ∈ set (remdups_wrt f xs)" and "y ∈ set (remdups_wrt f xs)" and "x ≠ y"
shows "f x ≠ f y"
using assms(1) assms(2)
proof (induct xs)
case Nil
thus ?case unfolding remdups_wrt_base by simp
next
case (Cons a xs)
from Cons(2) Cons(3) show ?case unfolding remdups_wrt_rec
proof (simp only: split: if_splits)
assume "x ∈ set (remdups_wrt f xs)" and "y ∈ set (remdups_wrt f xs)"
thus "f x ≠ f y" by (rule Cons.hyps)
next
assume "¬ True"
thus "f x ≠ f y" by simp
next
assume "f a ∉ f ` set xs" and xin: "x ∈ set (a # remdups_wrt f xs)" and yin: "y ∈ set (a # remdups_wrt f xs)"
from yin have y: "y = a ∨ y ∈ set (remdups_wrt f xs)" by simp
from xin have "x = a ∨ x ∈ set (remdups_wrt f xs)" by simp
thus "f x ≠ f y"
proof
assume "x = a"
from y show ?thesis
proof
assume "y = a"
with ‹x ≠ y› show ?thesis unfolding ‹x = a› by simp
next
assume "y ∈ set (remdups_wrt f xs)"
have "y ∈ set xs" by (rule, fact, rule subset_remdups_wrt)
hence "f y ∈ f ` set xs" by simp
with ‹f a ∉ f ` set xs› show ?thesis unfolding ‹x = a› by auto
qed
next
assume "x ∈ set (remdups_wrt f xs)"
from y show ?thesis
proof
assume "y = a"
have "x ∈ set xs" by (rule, fact, rule subset_remdups_wrt)
hence "f x ∈ f ` set xs" by simp
with ‹f a ∉ f ` set xs› show ?thesis unfolding ‹y = a› by auto
next
assume "y ∈ set (remdups_wrt f xs)"
with ‹x ∈ set (remdups_wrt f xs)› show ?thesis by (rule Cons.hyps)
qed
qed
qed
qed
lemma distinct_remdups_wrt: "distinct (remdups_wrt f xs)"
proof (induct xs)
case Nil
show ?case unfolding remdups_wrt_base by simp
next
case (Cons a xs)
show ?case unfolding remdups_wrt_rec
proof (split if_split, intro conjI impI, rule Cons.hyps)
assume "f a ∉ f ` set xs"
hence "a ∉ set xs" by auto
hence "a ∉ set (remdups_wrt f xs)" using subset_remdups_wrt[of f xs] by auto
with Cons.hyps show "distinct (a # remdups_wrt f xs)" by simp
qed
qed
lemma map_remdups_wrt: "map f (remdups_wrt f xs) = remdups (map f xs)"
by (induct xs, auto)
lemma remdups_wrt_append:
"remdups_wrt f (xs @ ys) = (filter (λa. f a ∉ f ` set ys) (remdups_wrt f xs)) @ (remdups_wrt f ys)"
by (induct xs, auto)
subsubsection ‹‹map_idx››
primrec map_idx :: "('a ⇒ nat ⇒ 'b) ⇒ 'a list ⇒ nat ⇒ 'b list" where
"map_idx f [] n = []"|
"map_idx f (x # xs) n = (f x n) # (map_idx f xs (Suc n))"
lemma map_idx_eq_map2: "map_idx f xs n = map2 f xs [n..<n + length xs]"
proof (induct xs arbitrary: n)
case Nil
show ?case by simp
next
case (Cons x xs)
have eq: "[n..<n + length (x # xs)] = n # [Suc n..<Suc (n + length xs)]"
by (metis add_Suc_right length_Cons less_add_Suc1 upt_conv_Cons)
show ?case unfolding eq by (simp add: Cons del: upt_Suc)
qed
lemma length_map_idx [simp]: "length (map_idx f xs n) = length xs"
by (simp add: map_idx_eq_map2)
lemma map_idx_append: "map_idx f (xs @ ys) n = (map_idx f xs n) @ (map_idx f ys (n + length xs))"
by (simp add: map_idx_eq_map2 ab_semigroup_add_class.add_ac(1) zip_append1)
lemma map_idx_nth:
assumes "i < length xs"
shows "(map_idx f xs n) ! i = f (xs ! i) (n + i)"
using assms by (simp add: map_idx_eq_map2)
lemma map_map_idx: "map f (map_idx g xs n) = map_idx (λx i. f (g x i)) xs n"
by (auto simp add: map_idx_eq_map2)
lemma map_idx_map: "map_idx f (map g xs) n = map_idx (f ∘ g) xs n"
by (simp add: map_idx_eq_map2 map_zip_map)
lemma map_idx_no_idx: "map_idx (λx _. f x) xs n = map f xs"
by (induct xs arbitrary: n, simp_all)
lemma map_idx_no_elem: "map_idx (λ_. f) xs n = map f [n..<n + length xs]"
proof (induct xs arbitrary: n)
case Nil
show ?case by simp
next
case (Cons x xs)
have eq: "[n..<n + length (x # xs)] = n # [Suc n..<Suc (n + length xs)]"
by (metis add_Suc_right length_Cons less_add_Suc1 upt_conv_Cons)
show ?case unfolding eq by (simp add: Cons del: upt_Suc)
qed
lemma map_idx_eq_map: "map_idx f xs n = map (λi. f (xs ! i) (i + n)) [0..<length xs]"
proof (induct xs arbitrary: n)
case Nil
show ?case by simp
next
case (Cons x xs)
have eq: "[0..<length (x # xs)] = 0 # [Suc 0..<Suc (length xs)]"
by (metis length_Cons upt_conv_Cons zero_less_Suc)
have "map (λi. f ((x # xs) ! i) (i + n)) [Suc 0..<Suc (length xs)] =
map ((λi. f ((x # xs) ! i) (i + n)) ∘ Suc) [0..<length xs]"
by (metis map_Suc_upt map_map)
also have "... = map (λi. f (xs ! i) (Suc (i + n))) [0..<length xs]"
by (rule map_cong, fact refl, simp)
finally show ?case unfolding eq by (simp add: Cons del: upt_Suc)
qed
lemma set_map_idx: "set (map_idx f xs n) = (λi. f (xs ! i) (i + n)) ` {0..<length xs}"
by (simp add: map_idx_eq_map)
subsubsection ‹‹map_dup››
primrec map_dup :: "('a ⇒ 'b) ⇒ ('a ⇒ 'b) ⇒ 'a list ⇒ 'b list" where
"map_dup _ _ [] = []"|
"map_dup f g (x # xs) = (if x ∈ set xs then g x else f x) # (map_dup f g xs)"
lemma length_map_dup[simp]: "length (map_dup f g xs) = length xs"
by (induct xs, simp_all)
lemma map_dup_distinct:
assumes "distinct xs"
shows "map_dup f g xs = map f xs"
using assms by (induct xs, simp_all)
lemma filter_map_dup_const:
"filter (λx. x ≠ c) (map_dup f (λ_. c) xs) = filter (λx. x ≠ c) (map f (remdups xs))"
by (induct xs, simp_all)
lemma filter_zip_map_dup_const:
"filter (λ(a, b). a ≠ c) (zip (map_dup f (λ_. c) xs) xs) =
filter (λ(a, b). a ≠ c) (zip (map f (remdups xs)) (remdups xs))"
by (induct xs, simp_all)
subsubsection ‹Filtering Minimal Elements›
context
fixes rel :: "'a ⇒ 'a ⇒ bool"
begin
primrec filter_min_aux :: "'a list ⇒ 'a list ⇒ 'a list" where
"filter_min_aux [] ys = ys"|
"filter_min_aux (x # xs) ys =
(if (∃y∈(set xs ∪ set ys). rel y x) then (filter_min_aux xs ys)
else (filter_min_aux xs (x # ys)))"
definition filter_min :: "'a list ⇒ 'a list"
where "filter_min xs = filter_min_aux xs []"
definition filter_min_append :: "'a list ⇒ 'a list ⇒ 'a list"
where "filter_min_append xs ys =
(let P = (λzs. λx. ¬ (∃z∈set zs. rel z x)); ys1 = filter (P xs) ys in
(filter (P ys1) xs) @ ys1)"
lemma filter_min_aux_supset: "set ys ⊆ set (filter_min_aux xs ys)"
proof (induct xs arbitrary: ys)
case Nil
show ?case by simp
next
case (Cons x xs)
have "set ys ⊆ set (x # ys)" by auto
also have "set (x # ys) ⊆ set (filter_min_aux xs (x # ys))" by (rule Cons.hyps)
finally have "set ys ⊆ set (filter_min_aux xs (x # ys))" .
moreover have "set ys ⊆ set (filter_min_aux xs ys)" by (rule Cons.hyps)
ultimately show ?case by simp
qed
lemma filter_min_aux_subset: "set (filter_min_aux xs ys) ⊆ set xs ∪ set ys"
proof (induct xs arbitrary: ys)
case Nil
show ?case by simp
next
case (Cons x xs)
note Cons.hyps
also have "set xs ∪ set ys ⊆ set (x # xs) ∪ set ys" by fastforce
finally have c1: "set (filter_min_aux xs ys) ⊆ set (x # xs) ∪ set ys" .
note Cons.hyps
also have "set xs ∪ set (x # ys) = set (x # xs) ∪ set ys" by simp
finally have "set (filter_min_aux xs (x # ys)) ⊆ set (x # xs) ∪ set ys" .
with c1 show ?case by simp
qed
lemma filter_min_aux_relE:
assumes "transp rel" and "x ∈ set xs" and "x ∉ set (filter_min_aux xs ys)"
obtains y where "y ∈ set (filter_min_aux xs ys)" and "rel y x"
using assms(2, 3)
proof (induct xs arbitrary: x ys thesis)
case Nil
from Nil(2) show ?case by simp
next
case (Cons x0 xs)
from Cons(3) have "x = x0 ∨ x ∈ set xs" by simp
thus ?case
proof
assume "x = x0"
from Cons(4) have *: "∃y∈set xs ∪ set ys. rel y x0"
proof (simp add: ‹x = x0› split: if_splits)
assume "x0 ∉ set (filter_min_aux xs (x0 # ys))"
moreover from filter_min_aux_supset have "x0 ∈ set (filter_min_aux xs (x0 # ys))"
by (rule subsetD) simp
ultimately show False ..
qed
hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs ys" by simp
from * obtain x1 where "x1 ∈ set xs ∪ set ys" and "rel x1 x" unfolding ‹x = x0› ..
from this(1) show ?thesis
proof
assume "x1 ∈ set xs"
show ?thesis
proof (cases "x1 ∈ set (filter_min_aux xs ys)")
case True
hence "x1 ∈ set (filter_min_aux (x0 # xs) ys)" by (simp only: eq)
thus ?thesis using ‹rel x1 x› by (rule Cons(2))
next
case False
with ‹x1 ∈ set xs› obtain y where "y ∈ set (filter_min_aux xs ys)" and "rel y x1"
using Cons.hyps by blast
from this(1) have "y ∈ set (filter_min_aux (x0 # xs) ys)" by (simp only: eq)
moreover from assms(1) ‹rel y x1› ‹rel x1 x› have "rel y x" by (rule transpD)
ultimately show ?thesis by (rule Cons(2))
qed
next
assume "x1 ∈ set ys"
hence "x1 ∈ set (filter_min_aux (x0 # xs) ys)" using filter_min_aux_supset ..
thus ?thesis using ‹rel x1 x› by (rule Cons(2))
qed
next
assume "x ∈ set xs"
show ?thesis
proof (cases "∃y∈set xs ∪ set ys. rel y x0")
case True
hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs ys" by simp
with Cons(4) have "x ∉ set (filter_min_aux xs ys)" by simp
with ‹x ∈ set xs› obtain y where "y ∈ set (filter_min_aux xs ys)" and "rel y x"
using Cons.hyps by blast
from this(1) have "y ∈ set (filter_min_aux (x0 # xs) ys)" by (simp only: eq)
thus ?thesis using ‹rel y x› by (rule Cons(2))
next
case False
hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs (x0 # ys)" by simp
with Cons(4) have "x ∉ set (filter_min_aux xs (x0 # ys))" by simp
with ‹x ∈ set xs› obtain y where "y ∈ set (filter_min_aux xs (x0 # ys))" and "rel y x"
using Cons.hyps by blast
from this(1) have "y ∈ set (filter_min_aux (x0 # xs) ys)" by (simp only: eq)
thus ?thesis using ‹rel y x› by (rule Cons(2))
qed
qed
qed
lemma filter_min_aux_minimal:
assumes "transp rel" and "x ∈ set (filter_min_aux xs ys)" and "y ∈ set (filter_min_aux xs ys)"
and "rel x y"
assumes "⋀a b. a ∈ set xs ∪ set ys ⟹ b ∈ set ys ⟹ rel a b ⟹ a = b"
shows "x = y"
using assms(2-5)
proof (induct xs arbitrary: x y ys)
case Nil
from Nil(1) have "x ∈ set [] ∪ set ys" by simp
moreover from Nil(2) have "y ∈ set ys" by simp
ultimately show ?case using Nil(3) by (rule Nil(4))
next
case (Cons x0 xs)
show ?case
proof (cases "∃y∈set xs ∪ set ys. rel y x0")
case True
hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs ys" by simp
with Cons(2, 3) have "x ∈ set (filter_min_aux xs ys)" and "y ∈ set (filter_min_aux xs ys)"
by simp_all
thus ?thesis using Cons(4)
proof (rule Cons.hyps)
fix a b
assume "a ∈ set xs ∪ set ys"
hence "a ∈ set (x0 # xs) ∪ set ys" by simp
moreover assume "b ∈ set ys" and "rel a b"
ultimately show "a = b" by (rule Cons(5))
qed
next
case False
hence eq: "filter_min_aux (x0 # xs) ys = filter_min_aux xs (x0 # ys)" by simp
with Cons(2, 3) have "x ∈ set (filter_min_aux xs (x0 # ys))" and "y ∈ set (filter_min_aux xs (x0 # ys))"
by simp_all
thus ?thesis using Cons(4)
proof (rule Cons.hyps)
fix a b
assume a: "a ∈ set xs ∪ set (x0 # ys)" and "b ∈ set (x0 # ys)" and "rel a b"
from this(2) have "b = x0 ∨ b ∈ set ys" by simp
thus "a = b"
proof
assume "b = x0"
from a have "a = x0 ∨ a ∈ set xs ∪ set ys" by simp
thus ?thesis
proof
assume "a = x0"
with ‹b = x0› show ?thesis by simp
next
assume "a ∈ set xs ∪ set ys"
hence "∃y∈set xs ∪ set ys. rel y x0" using ‹rel a b› unfolding ‹b = x0› ..
with False show ?thesis ..
qed
next
from a have "a ∈ set (x0 # xs) ∪ set ys" by simp
moreover assume "b ∈ set ys"
ultimately show ?thesis using ‹rel a b› by (rule Cons(5))
qed
qed
qed
qed
lemma filter_min_aux_distinct:
assumes "reflp rel" and "distinct ys"
shows "distinct (filter_min_aux xs ys)"
using assms(2)
proof (induct xs arbitrary: ys)
case Nil
thus ?case by simp
next
case (Cons x xs)
show ?case
proof (simp split: if_split, intro conjI impI)
from Cons(2) show "distinct (filter_min_aux xs ys)" by (rule Cons.hyps)
next
assume a: "∀y∈set xs ∪ set ys. ¬ rel y x"
show "distinct (filter_min_aux xs (x # ys))"
proof (rule Cons.hyps)
have "x ∉ set ys"
proof
assume "x ∈ set ys"
hence "x ∈ set xs ∪ set ys" by simp
with a have "¬ rel x x" ..
moreover from assms(1) have "rel x x" by (rule reflpD)
ultimately show False ..
qed
with Cons(2) show "distinct (x # ys)" by simp
qed
qed
qed
lemma filter_min_subset: "set (filter_min xs) ⊆ set xs"
using filter_min_aux_subset[of xs "[]"] by (simp add: filter_min_def)
lemma filter_min_cases:
assumes "transp rel" and "x ∈ set xs"
assumes "x ∈ set (filter_min xs) ⟹ thesis"
assumes "⋀y. y ∈ set (filter_min xs) ⟹ x ∉ set (filter_min xs) ⟹ rel y x ⟹ thesis"
shows thesis
proof (cases "x ∈ set (filter_min xs)")
case True
thus ?thesis by (rule assms(3))
next
case False
with assms(1, 2) obtain y where "y ∈ set (filter_min xs)" and "rel y x"
unfolding filter_min_def by (rule filter_min_aux_relE)
from this(1) False this(2) show ?thesis by (rule assms(4))
qed
corollary filter_min_relE:
assumes "transp rel" and "reflp rel" and "x ∈ set xs"
obtains y where "y ∈ set (filter_min xs)" and "rel y x"
using assms(1, 3)
proof (rule filter_min_cases)
assume "x ∈ set (filter_min xs)"
moreover from assms(2) have "rel x x" by (rule reflpD)
ultimately show ?thesis ..
qed
lemma filter_min_minimal:
assumes "transp rel" and "x ∈ set (filter_min xs)" and "y ∈ set (filter_min xs)" and "rel x y"
shows "x = y"
using assms unfolding filter_min_def by (rule filter_min_aux_minimal) simp
lemma filter_min_distinct:
assumes "reflp rel"
shows "distinct (filter_min xs)"
unfolding filter_min_def by (rule filter_min_aux_distinct, fact, simp)
lemma filter_min_append_subset: "set (filter_min_append xs ys) ⊆ set xs ∪ set ys"
by (auto simp: filter_min_append_def)
lemma filter_min_append_cases:
assumes "transp rel" and "x ∈ set xs ∪ set ys"
assumes "x ∈ set (filter_min_append xs ys) ⟹ thesis"
assumes "⋀y. y ∈ set (filter_min_append xs ys) ⟹ x ∉ set (filter_min_append xs ys) ⟹ rel y x ⟹ thesis"
shows thesis
proof (cases "x ∈ set (filter_min_append xs ys)")
case True
thus ?thesis by (rule assms(3))
next
case False
define P where "P = (λzs. λa. ¬ (∃z∈set zs. rel z a))"
from assms(2) obtain y where "y ∈ set (filter_min_append xs ys)" and "rel y x"
proof
assume "x ∈ set xs"
with False obtain y where "y ∈ set (filter_min_append xs ys)" and "rel y x"
by (auto simp: filter_min_append_def P_def)
thus ?thesis ..
next
assume "x ∈ set ys"
with False obtain y where "y ∈ set xs" and "rel y x"
by (auto simp: filter_min_append_def P_def)
show ?thesis
proof (cases "y ∈ set (filter_min_append xs ys)")
case True
thus ?thesis using ‹rel y x› ..
next
case False
with ‹y ∈ set xs› obtain y' where y': "y' ∈ set (filter_min_append xs ys)" and "rel y' y"
by (auto simp: filter_min_append_def P_def)
from assms(1) this(2) ‹rel y x› have "rel y' x" by (rule transpD)
with y' show ?thesis ..
qed
qed
from this(1) False this(2) show ?thesis by (rule assms(4))
qed
corollary filter_min_append_relE:
assumes "transp rel" and "reflp rel" and "x ∈ set xs ∪ set ys"
obtains y where "y ∈ set (filter_min_append xs ys)" and "rel y x"
using assms(1, 3)
proof (rule filter_min_append_cases)
assume "x ∈ set (filter_min_append xs ys)"
moreover from assms(2) have "rel x x" by (rule reflpD)
ultimately show ?thesis ..
qed
lemma filter_min_append_minimal:
assumes "⋀x' y'. x' ∈ set xs ⟹ y' ∈ set xs ⟹ rel x' y' ⟹ x' = y'"
and "⋀x' y'. x' ∈ set ys ⟹ y' ∈ set ys ⟹ rel x' y' ⟹ x' = y'"
and "x ∈ set (filter_min_append xs ys)" and "y ∈ set (filter_min_append xs ys)" and "rel x y"
shows "x = y"
proof -
define P where "P = (λzs. λa. ¬ (∃z∈set zs. rel z a))"
define ys1 where "ys1 = filter (P xs) ys"
from assms(3) have "x ∈ set xs ∪ set ys1"
by (auto simp: filter_min_append_def P_def ys1_def)
moreover from assms(4) have "y ∈ set (filter (P ys1) xs) ∪ set ys1"
by (simp add: filter_min_append_def P_def ys1_def)
ultimately show ?thesis
proof (elim UnE)
assume "x ∈ set xs"
assume "y ∈ set (filter (P ys1) xs)"
hence "y ∈ set xs" by simp
with ‹x ∈ set xs› show ?thesis using assms(5) by (rule assms(1))
next
assume "y ∈ set ys1"
hence "⋀z. z ∈ set xs ⟹ ¬ rel z y" by (simp add: ys1_def P_def)
moreover assume "x ∈ set xs"
ultimately have "¬ rel x y" by blast
thus ?thesis using ‹rel x y› ..
next
assume "y ∈ set (filter (P ys1) xs)"
hence "⋀z. z ∈ set ys1 ⟹ ¬ rel z y" by (simp add: P_def)
moreover assume "x ∈ set ys1"
ultimately have "¬ rel x y" by blast
thus ?thesis using ‹rel x y› ..
next
assume "x ∈ set ys1" and "y ∈ set ys1"
hence "x ∈ set ys" and "y ∈ set ys" by (simp_all add: ys1_def)
thus ?thesis using assms(5) by (rule assms(2))
qed
qed
lemma filter_min_append_distinct:
assumes "reflp rel" and "distinct xs" and "distinct ys"
shows "distinct (filter_min_append xs ys)"
proof -
define P where "P = (λzs. λa. ¬ (∃z∈set zs. rel z a))"
define ys1 where "ys1 = filter (P xs) ys"
from assms(2) have "distinct (filter (P ys1) xs)" by simp
moreover from assms(3) have "distinct ys1" by (simp add: ys1_def)
moreover have "set (filter (P ys1) xs) ∩ set ys1 = {}"
proof (simp add: set_eq_iff, intro allI impI notI)
fix x
assume "P ys1 x"
hence "⋀z. z ∈ set ys1 ⟹ ¬ rel z x" by (simp add: P_def)
moreover assume "x ∈ set ys1"
ultimately have "¬ rel x x" by blast
moreover from assms(1) have "rel x x" by (rule reflpD)
ultimately show False ..
qed
ultimately show ?thesis by (simp add: filter_min_append_def ys1_def P_def)
qed
end
end
Theory Confluence
section ‹Properties of Binary Relations›
theory Confluence
imports "Abstract-Rewriting.Abstract_Rewriting" "Open_Induction.Restricted_Predicates"
begin
text ‹This theory formalizes some general properties of binary relations, in particular a very weak
sufficient condition for a relation to be Church-Rosser.›
subsection ‹@{const wfp_on}›
lemma wfp_on_imp_wfP:
assumes "wfp_on r A"
shows "wfP (λx y. r x y ∧ x ∈ A ∧ y ∈ A)" (is "wfP ?r")
proof (simp add: wfP_def wf_def, intro allI impI)
fix P x
assume "∀x. (∀y. r y x ∧ y ∈ A ∧ x ∈ A ⟶ P y) ⟶ P x"
hence *: "⋀x. (⋀y. x ∈ A ⟹ y ∈ A ⟹ r y x ⟹ P y) ⟹ P x" by blast
from assms have **: "⋀a. a ∈ A ⟹ (⋀x. x ∈ A ⟹ (⋀y. y ∈ A ⟹ r y x ⟹ P y) ⟹ P x) ⟹ P a"
by (rule wfp_on_induct) blast+
show "P x"
proof (cases "x ∈ A")
case True
from this * show ?thesis by (rule **)
next
case False
show ?thesis
proof (rule *)
fix y
assume "x ∈ A"
with False show "P y" ..
qed
qed
qed
lemma wfp_onI_min:
assumes "⋀x Q. x ∈ Q ⟹ Q ⊆ A ⟹ ∃z∈Q. ∀y∈A. r y z ⟶ y ∉ Q"
shows "wfp_on r A"
proof (intro inductive_on_imp_wfp_on minimal_imp_inductive_on allI impI)
fix Q x
assume "x ∈ Q ∧ Q ⊆ A"
hence "x ∈ Q" and "Q ⊆ A" by simp_all
hence "∃z∈Q. ∀y∈A. r y z ⟶ y ∉ Q" by (rule assms)
then obtain z where "z ∈ Q" and 1: "⋀y. y ∈ A ⟹ r y z ⟹ y ∉ Q" by blast
show "∃z∈Q. ∀y. r y z ⟶ y ∉ Q"
proof (intro bexI allI impI)
fix y
assume "r y z"
show "y ∉ Q"
proof (cases "y ∈ A")
case True
thus ?thesis using ‹r y z› by (rule 1)
next
case False
with ‹Q ⊆ A› show ?thesis by blast
qed
qed fact
qed
lemma wfp_onE_min:
assumes "wfp_on r A" and "x ∈ Q" and "Q ⊆ A"
obtains z where "z ∈ Q" and "⋀y. r y z ⟹ y ∉ Q"
using wfp_on_imp_minimal[OF assms(1)] assms(2, 3) by blast
lemma wfp_onI_chain: "¬ (∃f. ∀i. f i ∈ A ∧ r (f (Suc i)) (f i)) ⟹ wfp_on r A"
by (simp add: wfp_on_def)
lemma finite_minimalE:
assumes "finite A" and "A ≠ {}" and "irreflp rel" and "transp rel"
obtains a where "a ∈ A" and "⋀b. rel b a ⟹ b ∉ A"
using assms(1, 2)
proof (induct arbitrary: thesis)
case empty
from empty(2) show ?case by simp
next
case (insert a A)
show ?case
proof (cases "A = {}")
case True
show ?thesis
proof (rule insert(4))
fix b
assume "rel b a"
with assms(3) show "b ∉ insert a A" by (auto simp: True irreflp_def)
qed simp
next
case False
with insert(3) obtain z where "z ∈ A" and *: "⋀b. rel b z ⟹ b ∉ A" by blast
show ?thesis
proof (cases "rel a z")
case True
show ?thesis
proof (rule insert(4))
fix b
assume "rel b a"
with assms(4) have "rel b z" using ‹rel a z› by (rule transpD)
hence "b ∉ A" by (rule *)
moreover from ‹rel b a› assms(3) have "b ≠ a" by (auto simp: irreflp_def)
ultimately show "b ∉ insert a A" by simp
qed simp
next
case False
show ?thesis
proof (rule insert(4))
fix b
assume "rel b z"
hence "b ∉ A" by (rule *)
moreover from ‹rel b z› False have "b ≠ a" by blast
ultimately show "b ∉ insert a A" by simp
next
from ‹z ∈ A› show "z ∈ insert a A" by simp
qed
qed
qed
qed
lemma wfp_on_finite:
assumes "irreflp rel" and "transp rel" and "finite A"
shows "wfp_on rel A"
proof (rule wfp_onI_min)
fix x Q
assume "x ∈ Q" and "Q ⊆ A"
from this(2) assms(3) have "finite Q" by (rule finite_subset)
moreover from ‹x ∈ Q› have "Q ≠ {}" by blast
ultimately obtain z where "z ∈ Q" and "⋀y. rel y z ⟹ y ∉ Q" using assms(1, 2)
by (rule finite_minimalE) blast
thus "∃z∈Q. ∀y∈A. rel y z ⟶ y ∉ Q" by blast
qed
subsection ‹Relations›
locale relation = fixes r::"'a ⇒ 'a ⇒ bool" (infixl "→" 50)
begin
abbreviation rtc::"'a ⇒ 'a ⇒ bool" (infixl "→⇧*" 50)
where "rtc a b ≡ r⇧*⇧* a b"
abbreviation sc::"'a ⇒ 'a ⇒ bool" (infixl "↔" 50)
where "sc a b ≡ a → b ∨ b → a"
definition is_final::"'a ⇒ bool" where
"is_final a ≡ ¬ (∃b. r a b)"
definition srtc::"'a ⇒ 'a ⇒ bool" (infixl "↔⇧*" 50) where
"srtc a b ≡ sc⇧*⇧* a b"
definition cs::"'a ⇒ 'a ⇒ bool" (infixl "↓⇧*" 50) where
"cs a b ≡ (∃s. (a →⇧* s) ∧ (b →⇧* s))"
definition is_confluent_on :: "'a set ⇒ bool"
where "is_confluent_on A ⟷ (∀a∈A. ∀b1 b2. (a →⇧* b1 ∧ a →⇧* b2) ⟶ b1 ↓⇧* b2)"
definition is_confluent :: bool
where "is_confluent ≡ is_confluent_on UNIV"
definition is_loc_confluent :: bool
where "is_loc_confluent ≡ (∀a b1 b2. (a → b1 ∧ a → b2) ⟶ b1 ↓⇧* b2)"
definition is_ChurchRosser :: bool
where "is_ChurchRosser ≡ (∀a b. a ↔⇧* b ⟶ a ↓⇧* b)"
definition dw_closed :: "'a set ⇒ bool"
where "dw_closed A ⟷ (∀a∈A. ∀b. a → b ⟶ b ∈ A)"
lemma dw_closedI [intro]:
assumes "⋀a b. a ∈ A ⟹ a → b ⟹ b ∈ A"
shows "dw_closed A"
unfolding dw_closed_def using assms by auto
lemma dw_closedD:
assumes "dw_closed A" and "a ∈ A" and "a → b"
shows "b ∈ A"
using assms unfolding dw_closed_def by auto
lemma dw_closed_rtrancl:
assumes "dw_closed A" and "a ∈ A" and "a →⇧* b"
shows "b ∈ A"
using assms(3)
proof (induct b)
case base
from assms(2) show ?case .
next
case (step y z)
from assms(1) step(3) step(2) show ?case by (rule dw_closedD)
qed
lemma dw_closed_empty: "dw_closed {}"
by (rule, simp)
lemma dw_closed_UNIV: "dw_closed UNIV"
by (rule, intro UNIV_I)
subsection ‹Setup for Connection to Theory @{theory "Abstract-Rewriting.Abstract_Rewriting"}›
abbreviation (input) relset::"('a * 'a) set" where
"relset ≡ {(x, y). x → y}"
lemma rtc_rtranclI:
assumes "a →⇧* b"
shows "(a, b) ∈ relset⇧*"
using assms by (simp only: Enum.rtranclp_rtrancl_eq)
lemma final_NF: "(is_final a) = (a ∈ NF relset)"
unfolding is_final_def NF_def by simp
lemma sc_symcl: "(a ↔ b) = ((a, b) ∈ relset⇧↔)"
by simp
lemma srtc_conversion: "(a ↔⇧* b) = ((a, b) ∈ relset⇧↔⇧*)"
proof -
have "{(a, b). (a, b) ∈ {(x, y). x → y}⇧↔} = {(a, b). a → b}⇧↔" by auto
thus ?thesis unfolding srtc_def conversion_def sc_symcl Enum.rtranclp_rtrancl_eq by simp
qed
lemma cs_join: "(a ↓⇧* b) = ((a, b) ∈ relset⇧↓)"
unfolding cs_def join_def by (auto simp add: Enum.rtranclp_rtrancl_eq rtrancl_converse)
lemma confluent_CR: "is_confluent = CR relset"
by (auto simp add: is_confluent_def is_confluent_on_def CR_defs Enum.rtranclp_rtrancl_eq cs_join)
lemma ChurchRosser_conversion: "is_ChurchRosser = (relset⇧↔⇧* ⊆ relset⇧↓)"
by (auto simp add: is_ChurchRosser_def cs_join srtc_conversion)
lemma loc_confluent_WCR:
shows "is_loc_confluent = WCR relset"
unfolding is_loc_confluent_def WCR_defs by (auto simp add: cs_join)
lemma wf_converse:
shows "(wfP r^--1) = (wf (relset¯))"
unfolding wfP_def converse_def by simp
lemma wf_SN:
shows "(wfP r^--1) = (SN relset)"
unfolding wf_converse wf_iff_no_infinite_down_chain SN_on_def by auto
subsection ‹Simple Lemmas›
lemma rtrancl_is_final:
assumes "a →⇧* b" and "is_final a"
shows "a = b"
proof -
from rtranclpD[OF ‹a →⇧* b›] show ?thesis
proof
assume "a ≠ b ∧ (→)⇧+⇧+ a b"
hence "(→)⇧+⇧+ a b" by simp
from ‹is_final a› final_NF have "a ∈ NF relset" by simp
from NF_no_trancl_step[OF this] have "(a, b) ∉ {(x, y). x → y}⇧+" ..
thus ?thesis using ‹(→)⇧+⇧+ a b› unfolding tranclp_unfold ..
qed
qed
lemma cs_refl:
shows "x ↓⇧* x"
unfolding cs_def
proof
show "x →⇧* x ∧ x →⇧* x" by simp
qed
lemma cs_sym:
assumes "x ↓⇧* y"
shows "y ↓⇧* x"
using assms unfolding cs_def
proof
fix z
assume a: "x →⇧* z ∧ y →⇧* z"
show "∃s. y →⇧* s ∧ x →⇧* s"
proof
from a show "y →⇧* z ∧ x →⇧* z" by simp
qed
qed
lemma rtc_implies_cs:
assumes "x →⇧* y"
shows "x ↓⇧* y"
proof -
from joinI_left[OF rtc_rtranclI[OF assms]] cs_join show ?thesis by simp
qed
lemma rtc_implies_srtc:
assumes "a →⇧* b"
shows "a ↔⇧* b"
proof -
from conversionI'[OF rtc_rtranclI[OF assms]] srtc_conversion show ?thesis by simp
qed
lemma srtc_symmetric:
assumes "a ↔⇧* b"
shows "b ↔⇧* a"
proof -
from symD[OF conversion_sym[of relset], of a b] assms srtc_conversion show ?thesis by simp
qed
lemma srtc_transitive:
assumes "a ↔⇧* b" and "b ↔⇧* c"
shows "a ↔⇧* c"
proof -
from rtranclp_trans[of "(↔)" a b c] assms show "a ↔⇧* c" unfolding srtc_def .
qed
lemma cs_implies_srtc:
assumes "a ↓⇧* b"
shows "a ↔⇧* b"
proof -
from assms cs_join have "(a, b) ∈ relset⇧↓" by simp
hence "(a, b) ∈ relset⇧↔⇧*" using join_imp_conversion by auto
thus ?thesis using srtc_conversion by simp
qed
lemma confluence_equiv_ChurchRosser: "is_confluent = is_ChurchRosser"
by (simp only: ChurchRosser_conversion confluent_CR, fact CR_iff_conversion_imp_join)
corollary confluence_implies_ChurchRosser:
assumes is_confluent
shows is_ChurchRosser
using assms by (simp only: confluence_equiv_ChurchRosser)
lemma ChurchRosser_unique_final:
assumes "is_ChurchRosser" and "a →⇧* b1" and "a →⇧* b2" and "is_final b1" and "is_final b2"
shows "b1 = b2"
proof -
from ‹is_ChurchRosser› confluence_equiv_ChurchRosser confluent_CR have "CR relset" by simp
from CR_imp_UNF[OF this] assms show ?thesis unfolding UNF_defs normalizability_def
by (auto simp add: Enum.rtranclp_rtrancl_eq final_NF)
qed
lemma wf_on_imp_nf_ex:
assumes "wfp_on ((→)¯¯) A" and "dw_closed A" and "a ∈ A"
obtains b where "a →⇧* b" and "is_final b"
proof -
let ?A = "{b∈A. a →⇧* b}"
note assms(1)
moreover from assms(3) have "a ∈ ?A" by simp
moreover have "?A ⊆ A" by auto
ultimately show ?thesis
proof (rule wfp_onE_min)
fix z
assume "z ∈ ?A" and "⋀y. (→)¯¯ y z ⟹ y ∉ ?A"
from this(2) have *: "⋀y. z → y ⟹ y ∉ ?A" by simp
from ‹z ∈ ?A› have "z ∈ A" and "a →⇧* z" by simp_all
show thesis
proof (rule, fact)
show "is_final z" unfolding is_final_def
proof
assume "∃y. z → y"
then obtain y where "z → y" ..
hence "y ∉ ?A" by (rule *)
moreover from assms(2) ‹z ∈ A› ‹z → y› have "y ∈ A" by (rule dw_closedD)
ultimately have "¬ (a →⇧* y)" by simp
with rtranclp_trans[OF ‹a →⇧* z›, of y] ‹z → y› show False by auto
qed
qed
qed
qed
lemma unique_nf_imp_confluence_on:
assumes major: "⋀a b1 b2. a ∈ A ⟹ (a →⇧* b1) ⟹ (a →⇧* b2) ⟹ is_final b1 ⟹ is_final b2 ⟹ b1 = b2"
and wf: "wfp_on ((→)¯¯) A" and dw: "dw_closed A"
shows "is_confluent_on A"
unfolding is_confluent_on_def
proof (intro ballI allI impI)
fix a b1 b2
assume "a →⇧* b1 ∧ a →⇧* b2"
hence "a →⇧* b1" and "a →⇧* b2" by simp_all
assume "a ∈ A"
from dw this ‹a →⇧* b1› have "b1 ∈ A" by (rule dw_closed_rtrancl)
from wf dw this obtain c1 where "b1 →⇧* c1" and "is_final c1" by (rule wf_on_imp_nf_ex)
from dw ‹a ∈ A› ‹a →⇧* b2› have "b2 ∈ A" by (rule dw_closed_rtrancl)
from wf dw this obtain c2 where "b2 →⇧* c2" and "is_final c2" by (rule wf_on_imp_nf_ex)
have "c1 = c2"
by (rule major, fact, rule rtranclp_trans[OF ‹a →⇧* b1›], fact, rule rtranclp_trans[OF ‹a →⇧* b2›], fact+)
show "b1 ↓⇧* b2" unfolding cs_def
proof (intro exI, intro conjI)
show "b1 →⇧* c1" by fact
next
show "b2 →⇧* c1" unfolding ‹c1 = c2› by fact
qed
qed
corollary wf_imp_nf_ex:
assumes "wfP ((→)¯¯)"
obtains b where "a →⇧* b" and "is_final b"
proof -
from assms have "wfp_on (r^--1) UNIV" by simp
moreover note dw_closed_UNIV
moreover have "a ∈ UNIV" ..
ultimately obtain b where "a →⇧* b" and "is_final b" by (rule wf_on_imp_nf_ex)
thus ?thesis ..
qed
corollary unique_nf_imp_confluence:
assumes "⋀a b1 b2. (a →⇧* b1) ⟹ (a →⇧* b2) ⟹ is_final b1 ⟹ is_final b2 ⟹ b1 = b2"
and "wfP ((→)¯¯)"
shows "is_confluent"
unfolding is_confluent_def
by (rule unique_nf_imp_confluence_on, erule assms(1), assumption+, simp add: assms(2), fact dw_closed_UNIV)
end
subsection ‹Advanced Results and the Generalized Newman Lemma›
definition relbelow_on :: "'a set ⇒ ('a ⇒ 'a ⇒ bool) ⇒ 'a ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'a ⇒ bool)"
where "relbelow_on A ord z rel a b ≡ (a ∈ A ∧ b ∈ A ∧ rel a b ∧ ord a z ∧ ord b z)"
definition cbelow_on_1 :: "'a set ⇒ ('a ⇒ 'a ⇒ bool) ⇒ 'a ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'a ⇒ bool)"
where "cbelow_on_1 A ord z rel ≡ (relbelow_on A ord z rel)⇧+⇧+"
definition cbelow_on :: "'a set ⇒ ('a ⇒ 'a ⇒ bool) ⇒ 'a ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'a ⇒ bool)"
where "cbelow_on A ord z rel a b ≡ (a = b ∧ b ∈ A ∧ ord b z) ∨ cbelow_on_1 A ord z rel a b"
text ‹Note that @{const cbelow_on} cannot be defined as the reflexive-transitive closure of
@{const relbelow_on}, since it is in general not reflexive!›
definition is_loc_connective_on :: "'a set ⇒ ('a ⇒ 'a ⇒ bool) ⇒ ('a ⇒ 'a ⇒ bool) ⇒ bool"
where "is_loc_connective_on A ord r ⟷ (∀a∈A. ∀b1 b2. r a b1 ∧ r a b2 ⟶ cbelow_on A ord a (relation.sc r) b1 b2)"
text ‹Note that @{const wfp_on} is @{emph ‹not›} the same as @{const SN_on}, since in the definition
of @{const SN_on} only the @{emph ‹first›} element of the chain must be in the set.›
lemma cbelow_on_first_below:
assumes "cbelow_on A ord z rel a b"
shows "ord a z"
using assms unfolding cbelow_on_def
proof
assume "cbelow_on_1 A ord z rel a b"
thus "ord a z" unfolding cbelow_on_1_def by (induct rule: tranclp_induct, simp add: relbelow_on_def)
qed simp
lemma cbelow_on_second_below:
assumes "cbelow_on A ord z rel a b"
shows "ord b z"
using assms unfolding cbelow_on_def
proof
assume "cbelow_on_1 A ord z rel a b"
thus "ord b z" unfolding cbelow_on_1_def
by (induct rule: tranclp_induct, simp_all add: relbelow_on_def)
qed simp
lemma cbelow_on_first_in:
assumes "cbelow_on A ord z rel a b"
shows "a ∈ A"
using assms unfolding cbelow_on_def
proof
assume "cbelow_on_1 A ord z rel a b"
thus ?thesis unfolding cbelow_on_1_def by (induct rule: tranclp_induct, simp add: relbelow_on_def)
qed simp
lemma cbelow_on_second_in:
assumes "cbelow_on A ord z rel a b"
shows "b ∈ A"
using assms unfolding cbelow_on_def
proof
assume "cbelow_on_1 A ord z rel a b"
thus ?thesis unfolding cbelow_on_1_def
by (induct rule: tranclp_induct, simp_all add: relbelow_on_def)
qed simp
lemma cbelow_on_intro [intro]:
assumes main: "cbelow_on A ord z rel a b" and "c ∈ A" and "rel b c" and "ord c z"
shows "cbelow_on A ord z rel a c"
proof -
from main have "b ∈ A" by (rule cbelow_on_second_in)
from main show ?thesis unfolding cbelow_on_def
proof (intro disjI2)
assume cases: "(a = b ∧ b ∈ A ∧ ord b z) ∨ cbelow_on_1 A ord z rel a b"
from ‹b ∈ A› ‹c ∈ A› ‹rel b c› ‹ord c z› cbelow_on_second_below[OF main]
have bc: "relbelow_on A ord z rel b c" by (simp add: relbelow_on_def)
from cases show "cbelow_on_1 A ord z rel a c"
proof
assume "a = b ∧ b ∈ A ∧ ord b z"
from this bc have "relbelow_on A ord z rel a c" by simp
thus ?thesis by (simp add: cbelow_on_1_def)
next
assume "cbelow_on_1 A ord z rel a b"
from this bc show ?thesis unfolding cbelow_on_1_def by (rule tranclp.intros(2))
qed
qed
qed
lemma cbelow_on_induct [consumes 1, case_names base step]:
assumes a: "cbelow_on A ord z rel a b"
and base: "a ∈ A ⟹ ord a z ⟹ P a"
and ind: "⋀b c. [| cbelow_on A ord z rel a b; rel b c; c ∈ A; ord c z; P b |] ==> P c"
shows "P b"
using a unfolding cbelow_on_def
proof
assume "a = b ∧ b ∈ A ∧ ord b z"
from this base show "P b" by simp
next
assume "cbelow_on_1 A ord z rel a b"
thus "P b" unfolding cbelow_on_1_def
proof (induct x≡a b)
fix b
assume "relbelow_on A ord z rel a b"
hence "rel a b" and "a ∈ A" and "b ∈ A" and "ord a z" and "ord b z"
by (simp_all add: relbelow_on_def)
hence "cbelow_on A ord z rel a a" by (simp add: cbelow_on_def)
from this ‹rel a b› ‹b ∈ A› ‹ord b z› base[OF ‹a ∈ A› ‹ord a z›] show "P b" by (rule ind)
next
fix b c
assume IH: "(relbelow_on A ord z rel)⇧+⇧+ a b" and "P b" and "relbelow_on A ord z rel b c"
hence "rel b c" and "b ∈ A" and "c ∈ A" and "ord b z" and "ord c z"
by (simp_all add: relbelow_on_def)
from IH have "cbelow_on A ord z rel a b" by (simp add: cbelow_on_def cbelow_on_1_def)
from this ‹rel b c› ‹c ∈ A› ‹ord c z› ‹P b› show "P c" by (rule ind)
qed
qed
lemma cbelow_on_symmetric:
assumes main: "cbelow_on A ord z rel a b" and "symp rel"
shows "cbelow_on A ord z rel b a"
using main unfolding cbelow_on_def
proof
assume a1: "a = b ∧ b ∈ A ∧ ord b z"
show "b = a ∧ a ∈ A ∧ ord a z ∨ cbelow_on_1 A ord z rel b a"
proof
from a1 show "b = a ∧ a ∈ A ∧ ord a z" by simp
qed
next
assume a2: "cbelow_on_1 A ord z rel a b"
show "b = a ∧ a ∈ A ∧ ord a z ∨ cbelow_on_1 A ord z rel b a"
proof (rule disjI2)
from ‹symp rel› have "symp (relbelow_on A ord z rel)" unfolding symp_def
proof (intro allI impI)
fix x y
assume rel_sym: "∀x y. rel x y ⟶ rel y x"
assume "relbelow_on A ord z rel x y"
hence "rel x y" and "x ∈ A" and "y ∈ A" and "ord x z" and "ord y z"
by (simp_all add: relbelow_on_def)
show "relbelow_on A ord z rel y x" unfolding relbelow_on_def
proof (intro conjI)
from rel_sym ‹rel x y› show "rel y x" by simp
qed fact+
qed
from sym_trancl[to_pred, OF this] a2 show "cbelow_on_1 A ord z rel b a"
by (simp add: symp_def cbelow_on_1_def)
qed
qed
lemma cbelow_on_transitive:
assumes "cbelow_on A ord z rel a b" and "cbelow_on A ord z rel b c"
shows "cbelow_on A ord z rel a c"
proof (induct rule: cbelow_on_induct[OF ‹cbelow_on A ord z rel b c›])
from ‹cbelow_on A ord z rel a b› show "cbelow_on A ord z rel a b" .
next
fix c0 c
assume "cbelow_on A ord z rel b c0" and "rel c0 c" and "c ∈ A" and "ord c z" and "cbelow_on A ord z rel a c0"
show "cbelow_on A ord z rel a c" by (rule, fact+)
qed
lemma cbelow_on_mono:
assumes "cbelow_on A ord z rel a b" and "A ⊆ B"
shows "cbelow_on B ord z rel a b"
using assms(1)
proof (induct rule: cbelow_on_induct)
case base
show ?case by (simp add: cbelow_on_def, intro disjI1 conjI, rule, fact+)
next
case (step b c)
from step(3) assms(2) have "c ∈ B" ..
from step(5) this step(2) step (4) show ?case ..
qed
locale relation_order = relation +
fixes ord::"'a ⇒ 'a ⇒ bool"
fixes A::"'a set"
assumes trans: "ord x y ⟹ ord y z ⟹ ord x z"
assumes wf: "wfp_on ord A"
assumes refines: "(→) ≤ ord¯¯"
begin
lemma relation_refines:
assumes "a → b"
shows "ord b a"
using refines assms by auto
lemma relation_wf: "wfp_on (→)¯¯ A"
using subset_refl _ wf
proof (rule wfp_on_mono)
fix x y
assume "(→)¯¯ x y"
hence "y → x" by simp
with refines have "(ord)¯¯ y x" ..
thus "ord x y" by simp
qed
lemma rtc_implies_cbelow_on:
assumes "dw_closed A" and main: "a →⇧* b" and "a ∈ A" and "ord a c"
shows "cbelow_on A ord c (↔) a b"
using main
proof (induct rule: rtranclp_induct)
from assms(3) assms(4) show "cbelow_on A ord c (↔) a a" by (simp add: cbelow_on_def)
next
fix b0 b
assume "a →⇧* b0" and "b0 → b" and IH: "cbelow_on A ord c (↔) a b0"
from assms(1) assms(3) ‹a →⇧* b0› have "b0 ∈ A" by (rule dw_closed_rtrancl)
from assms(1) this ‹b0 → b› have "b ∈ A" by (rule dw_closedD)
show "cbelow_on A ord c (↔) a b"
proof
from ‹b0 → b› show "b0 ↔ b" by simp
next
from relation_refines[OF ‹b0 → b›] cbelow_on_second_below[OF IH] show "ord b c" by (rule trans)
qed fact+
qed
lemma cs_implies_cbelow_on:
assumes "dw_closed A" and "a ↓⇧* b" and "a ∈ A" and "b ∈ A" and "ord a c" and "ord b c"
shows "cbelow_on A ord c (↔) a b"
proof -
from ‹a ↓⇧* b› obtain s where "a →⇧* s" and "b →⇧* s" unfolding cs_def by auto
have sym: "symp (↔)" unfolding symp_def
proof (intro allI, intro impI)
fix x y
assume "x ↔ y"
thus "y ↔ x" by auto
qed
from assms(1) ‹a →⇧* s› assms(3) assms(5) have "cbelow_on A ord c (↔) a s"
by (rule rtc_implies_cbelow_on)
also have "cbelow_on A ord c (↔) s b"
proof (rule cbelow_on_symmetric)
from assms(1) ‹b →⇧* s› assms(4) assms(6) show "cbelow_on A ord c (↔) b s"
by (rule rtc_implies_cbelow_on)
qed fact
finally(cbelow_on_transitive) show ?thesis .
qed
text ‹The generalized Newman lemma, taken from @{cite Winkler1983}:›
lemma loc_connectivity_implies_confluence:
assumes "is_loc_connective_on A ord (→)" and "dw_closed A"
shows "is_confluent_on A"
using assms(1) unfolding is_loc_connective_on_def is_confluent_on_def
proof (intro ballI allI impI)
fix z x y::'a
assume "∀a∈A. ∀b1 b2. a → b1 ∧ a → b2 ⟶ cbelow_on A ord a (↔) b1 b2"
hence A: "⋀a b1 b2. a ∈ A ⟹ a → b1 ⟹ a → b2 ⟹ cbelow_on A ord a (↔) b1 b2" by simp
assume "z ∈ A" and "z →⇧* x ∧ z →⇧* y"
with wf show "x ↓⇧* y"
proof (induct z arbitrary: x y rule: wfp_on_induct)
fix z x y::'a
assume IH: "⋀z0 x0 y0. z0 ∈ A ⟹ ord z0 z ⟹ z0 →⇧* x0 ∧ z0 →⇧* y0 ⟹ x0 ↓⇧* y0"
and "z →⇧* x ∧ z →⇧* y"
hence "z →⇧* x" and "z →⇧* y" by auto
assume "z ∈ A"
from converse_rtranclpE[OF ‹z →⇧* x›] obtain x1 where "x = z ∨ (z → x1 ∧ x1 →⇧* x)" by auto
thus "x ↓⇧* y"
proof
assume "x = z"
show ?thesis unfolding cs_def
proof
from ‹x = z› ‹z →⇧* y› show "x →⇧* y ∧ y →⇧* y" by simp
qed
next
assume "z → x1 ∧ x1 →⇧* x"
hence "z → x1" and "x1 →⇧* x" by auto
from assms(2) ‹z ∈ A› this(1) have "x1 ∈ A" by (rule dw_closedD)
from converse_rtranclpE[OF ‹z →⇧* y›] obtain y1 where "y = z ∨ (z → y1 ∧ y1 →⇧* y)" by auto
thus ?thesis
proof
assume "y = z"
show ?thesis unfolding cs_def
proof
from ‹y = z› ‹z →⇧* x› show "x →⇧* x ∧ y →⇧* x" by simp
qed
next
assume "z → y1 ∧ y1 →⇧* y"
hence "z → y1" and "y1 →⇧* y" by auto
from assms(2) ‹z ∈ A› this(1) have "y1 ∈ A" by (rule dw_closedD)
have "x1 ↓⇧* y1"
proof (induct rule: cbelow_on_induct[OF A[OF ‹z ∈ A› ‹z → x1› ‹z → y1›]])
from cs_refl[of x1] show "x1 ↓⇧* x1" .
next
fix b c
assume "cbelow_on A ord z (↔) x1 b" and "b ↔ c" and "c ∈ A" and "ord c z" and "x1 ↓⇧* b"
from this(1) have "b ∈ A" by (rule cbelow_on_second_in)
from ‹x1 ↓⇧* b› obtain w1 where "x1 →⇧* w1" and "b →⇧* w1" unfolding cs_def by auto
from ‹b ↔ c› show "x1 ↓⇧* c"
proof
assume "b → c"
hence "b →⇧* c" by simp
from ‹cbelow_on A ord z (↔) x1 b› have "ord b z" by (rule cbelow_on_second_below)
from IH[OF ‹b ∈ A› this] ‹b →⇧* c› ‹b →⇧* w1› have "c ↓⇧* w1" by simp
then obtain w2 where "c →⇧* w2" and "w1 →⇧* w2" unfolding cs_def by auto
show ?thesis unfolding cs_def
proof
from rtranclp_trans[OF ‹x1 →⇧* w1› ‹w1 →⇧* w2›] ‹c →⇧* w2›
show "x1 →⇧* w2 ∧ c →⇧* w2" by simp
qed
next
assume "c → b"
hence "c →⇧* b" by simp
show ?thesis unfolding cs_def
proof
from rtranclp_trans[OF ‹c →⇧* b› ‹b →⇧* w1›] ‹x1 →⇧* w1›
show "x1 →⇧* w1 ∧ c →⇧* w1" by simp
qed
qed
qed
then obtain w1 where "x1 →⇧* w1" and "y1 →⇧* w1" unfolding cs_def by auto
from IH[OF ‹x1 ∈ A› relation_refines[OF ‹z → x1›]] ‹x1 →⇧* x› ‹x1 →⇧* w1›
have "x ↓⇧* w1" by simp
then obtain v where "x →⇧* v" and "w1 →⇧* v" unfolding cs_def by auto
from IH[OF ‹y1 ∈ A› relation_refines[OF ‹z → y1›]]
rtranclp_trans[OF ‹y1 →⇧* w1› ‹w1 →⇧* v›] ‹y1 →⇧* y›
have "v ↓⇧* y" by simp
then obtain w where "v →⇧* w" and "y →⇧* w" unfolding cs_def by auto
show ?thesis unfolding cs_def
proof
from rtranclp_trans[OF ‹x →⇧* v› ‹v →⇧* w›] ‹y →⇧* w› show "x →⇧* w ∧ y →⇧* w" by simp
qed
qed
qed
qed
qed
end
theorem loc_connectivity_equiv_ChurchRosser:
assumes "relation_order r ord UNIV"
shows "relation.is_ChurchRosser r = is_loc_connective_on UNIV ord r"
proof
assume "relation.is_ChurchRosser r"
show "is_loc_connective_on UNIV ord r" unfolding is_loc_connective_on_def
proof (intro ballI allI impI)
fix a b1 b2
assume "r a b1 ∧ r a b2"
hence "r a b1" and "r a b2" by simp_all
hence "r⇧*⇧* a b1" and "r⇧*⇧* a b2" by simp_all
from relation.rtc_implies_srtc[OF ‹r⇧*⇧* a b1›] have "relation.srtc r b1 a" by (rule relation.srtc_symmetric)
from relation.srtc_transitive[OF this relation.rtc_implies_srtc[OF ‹r⇧*⇧* a b2›]] have "relation.srtc r b1 b2" .
with ‹relation.is_ChurchRosser r› have "relation.cs r b1 b2" by (simp add: relation.is_ChurchRosser_def)
from relation_order.cs_implies_cbelow_on[OF assms relation.dw_closed_UNIV this]
relation_order.relation_refines[OF assms, of a] ‹r a b1› ‹r a b2›
show "cbelow_on UNIV ord a (relation.sc r) b1 b2" by simp
qed
next
assume "is_loc_connective_on UNIV ord r"
from assms this relation.dw_closed_UNIV have "relation.is_confluent_on r UNIV"
by (rule relation_order.loc_connectivity_implies_confluence)
hence "relation.is_confluent r" by (simp only: relation.is_confluent_def)
thus "relation.is_ChurchRosser r" by (simp add: relation.confluence_equiv_ChurchRosser)
qed
end
Theory Reduction
section ‹Polynomial Reduction›
theory Reduction
imports "Polynomials.MPoly_Type_Class_Ordered" Confluence
begin
text ‹This theory formalizes the concept of @{emph ‹reduction›} of polynomials by polynomials.›
context ordered_term
begin
definition red_single :: "('t ⇒⇩0 'b::field) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ 'a ⇒ bool"
where "red_single p q f t ⟷ (f ≠ 0 ∧ lookup p (t ⊕ lt f) ≠ 0 ∧
q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f)"
definition red :: "('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ bool"
where "red F p q ⟷ (∃f∈F. ∃t. red_single p q f t)"
definition is_red :: "('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) ⇒ bool"
where "is_red F a ⟷ ¬ relation.is_final (red F) a"
subsection ‹Basic Properties of Reduction›
lemma red_setI:
assumes "f ∈ F" and a: "red_single p q f t"
shows "red F p q"
unfolding red_def
proof
from ‹f ∈ F› show "f ∈ F" .
next
from a show "∃t. red_single p q f t" ..
qed
lemma red_setE:
assumes "red F p q"
obtains f and t where "f ∈ F" and "red_single p q f t"
proof -
from assms obtain f where "f ∈ F" and t: "∃t. red_single p q f t" unfolding red_def by auto
from t obtain t where "red_single p q f t" ..
from ‹f ∈ F› this show "?thesis" ..
qed
lemma red_empty: "¬ red {} p q"
by (rule, elim red_setE, simp)
lemma red_singleton_zero: "¬ red {0} p q"
by (rule, elim red_setE, simp add: red_single_def)
lemma red_union: "red (F ∪ G) p q = (red F p q ∨ red G p q)"
proof
assume "red (F ∪ G) p q"
from red_setE[OF this] obtain f t where "f ∈ F ∪ G" and r: "red_single p q f t" .
from ‹f ∈ F ∪ G› have "f ∈ F ∨ f ∈ G" by simp
thus "red F p q ∨ red G p q"
proof
assume "f ∈ F"
show ?thesis by (intro disjI1, rule red_setI[OF ‹f ∈ F› r])
next
assume "f ∈ G"
show ?thesis by (intro disjI2, rule red_setI[OF ‹f ∈ G› r])
qed
next
assume "red F p q ∨ red G p q"
thus "red (F ∪ G) p q"
proof
assume "red F p q"
from red_setE[OF this] obtain f t where "f ∈ F" and "red_single p q f t" .
show ?thesis by (intro red_setI[of f _ _ _ t], rule UnI1, rule ‹f ∈ F›, fact)
next
assume "red G p q"
from red_setE[OF this] obtain f t where "f ∈ G" and "red_single p q f t" .
show ?thesis by (intro red_setI[of f _ _ _ t], rule UnI2, rule ‹f ∈ G›, fact)
qed
qed
lemma red_unionI1:
assumes "red F p q"
shows "red (F ∪ G) p q"
unfolding red_union by (rule disjI1, fact)
lemma red_unionI2:
assumes "red G p q"
shows "red (F ∪ G) p q"
unfolding red_union by (rule disjI2, fact)
lemma red_subset:
assumes "red G p q" and "G ⊆ F"
shows "red F p q"
proof -
from ‹G ⊆ F› obtain H where "F = G ∪ H" by auto
show ?thesis unfolding ‹F = G ∪ H› by (rule red_unionI1, fact)
qed
lemma red_union_singleton_zero: "red (F ∪ {0}) = red F"
by (intro ext, simp only: red_union red_singleton_zero, simp)
lemma red_minus_singleton_zero: "red (F - {0}) = red F"
by (metis Un_Diff_cancel2 red_union_singleton_zero)
lemma red_rtrancl_subset:
assumes major: "(red G)⇧*⇧* p q" and "G ⊆ F"
shows "(red F)⇧*⇧* p q"
using major
proof (induct rule: rtranclp_induct)
show "(red F)⇧*⇧* p p" ..
next
fix r q
assume "red G r q" and "(red F)⇧*⇧* p r"
show "(red F)⇧*⇧* p q"
proof
show "(red F)⇧*⇧* p r" by fact
next
from red_subset[OF ‹red G r q› ‹G ⊆ F›] show "red F r q" .
qed
qed
lemma red_singleton: "red {f} p q ⟷ (∃t. red_single p q f t)"
unfolding red_def
proof
assume "∃f∈{f}. ∃t. red_single p q f t"
from this obtain f0 where "f0 ∈ {f}" and a: "∃t. red_single p q f0 t" ..
from ‹f0 ∈ {f}› have "f0 = f" by simp
from this a show "∃t. red_single p q f t" by simp
next
assume a: "∃t. red_single p q f t"
show "∃f∈{f}. ∃t. red_single p q f t"
proof (rule, simp)
from a show "∃t. red_single p q f t" .
qed
qed
lemma red_single_lookup:
assumes "red_single p q f t"
shows "lookup q (t ⊕ lt f) = 0"
using assms unfolding red_single_def
proof
assume "f ≠ 0" and "lookup p (t ⊕ lt f) ≠ 0 ∧ q = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f"
hence "lookup p (t ⊕ lt f) ≠ 0" and q_def: "q = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f"
by auto
from lookup_minus[of p "monom_mult (lookup p (t ⊕ lt f) / lc f) t f" "t ⊕ lt f"]
lookup_monom_mult_plus[of "lookup p (t ⊕ lt f) / lc f" t f "lt f"]
lc_not_0[OF ‹f ≠ 0›]
show ?thesis unfolding q_def lc_def by simp
qed
lemma red_single_higher:
assumes "red_single p q f t"
shows "higher q (t ⊕ lt f) = higher p (t ⊕ lt f)"
using assms unfolding higher_eq_iff red_single_def
proof (intro allI, intro impI)
fix u
assume a: "t ⊕ lt f ≺⇩t u"
and "f ≠ 0 ∧ lookup p (t ⊕ lt f) ≠ 0 ∧ q = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f"
hence "f ≠ 0"
and "lookup p (t ⊕ lt f) ≠ 0"
and q_def: "q = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f"
by simp_all
from ‹lookup p (t ⊕ lt f) ≠ 0› lc_not_0[OF ‹f ≠ 0›] have c_not_0: "lookup p (t ⊕ lt f) / lc f ≠ 0"
by (simp add: field_simps)
from q_def lookup_minus[of p "monom_mult (lookup p (t ⊕ lt f) / lc f) t f"]
have q_lookup: "⋀s. lookup q s = lookup p s - lookup (monom_mult (lookup p (t ⊕ lt f) / lc f) t f) s"
by simp
from a lt_monom_mult[OF c_not_0 ‹f ≠ 0›, of t]
have "¬ u ≼⇩t lt (monom_mult (lookup p (t ⊕ lt f) / lc f) t f)" by simp
with lt_max[of "monom_mult (lookup p (t ⊕ lt f) / lc f) t f" u]
have "lookup (monom_mult (lookup p (t ⊕ lt f) / lc f) t f) u = 0" by auto
thus "lookup q u = lookup p u" using q_lookup[of u] by simp
qed
lemma red_single_ord:
assumes "red_single p q f t"
shows "q ≺⇩p p"
unfolding ord_strict_higher
proof (intro exI, intro conjI)
from red_single_lookup[OF assms] show "lookup q (t ⊕ lt f) = 0" .
next
from assms show "lookup p (t ⊕ lt f) ≠ 0" unfolding red_single_def by simp
next
from red_single_higher[OF assms] show "higher q (t ⊕ lt f) = higher p (t ⊕ lt f)" .
qed
lemma red_single_nonzero1:
assumes "red_single p q f t"
shows "p ≠ 0"
proof
assume "p = 0"
from this red_single_ord[OF assms] ord_p_zero_min[of q] show False by simp
qed
lemma red_single_nonzero2:
assumes "red_single p q f t"
shows "f ≠ 0"
proof
assume "f = 0"
from assms monom_mult_zero_right have "f ≠ 0" by (simp add: red_single_def)
from this ‹f = 0› show False by simp
qed
lemma red_single_self:
assumes "p ≠ 0"
shows "red_single p 0 p 0"
proof -
from lc_not_0[OF assms] have lc: "lc p ≠ 0" .
show ?thesis unfolding red_single_def
proof (intro conjI)
show "p ≠ 0" by fact
next
from lc show "lookup p (0 ⊕ lt p) ≠ 0" unfolding lc_def by (simp add: term_simps)
next
from lc have "(lookup p (0 ⊕ lt p)) / lc p = 1" unfolding lc_def by (simp add: term_simps)
from this monom_mult_one_left[of p] show "0 = p - monom_mult (lookup p (0 ⊕ lt p) / lc p) 0 p"
by simp
qed
qed
lemma red_single_trans:
assumes "red_single p p0 f t" and "lt g adds⇩t lt f" and "g ≠ 0"
obtains p1 where "red_single p p1 g (t + (lp f - lp g))"
proof -
let ?s = "t + (lp f - lp g)"
let ?p = "p - monom_mult (lookup p (?s ⊕ lt g) / lc g) ?s g"
have "red_single p ?p g ?s" unfolding red_single_def
proof (intro conjI)
from assms(2) have eq: "?s ⊕ lt g = t ⊕ lt f" using adds_term_alt splus_assoc
by (auto simp: term_simps)
from ‹red_single p p0 f t› have "lookup p (t ⊕ lt f) ≠ 0" unfolding red_single_def by simp
thus "lookup p (?s ⊕ lt g) ≠ 0" by (simp add: eq)
qed (fact, fact refl)
thus ?thesis ..
qed
lemma red_nonzero:
assumes "red F p q"
shows "p ≠ 0"
proof -
from red_setE[OF assms] obtain f t where "red_single p q f t" .
show ?thesis by (rule red_single_nonzero1, fact)
qed
lemma red_self:
assumes "p ≠ 0"
shows "red {p} p 0"
unfolding red_singleton
proof
from red_single_self[OF assms] show "red_single p 0 p 0" .
qed
lemma red_ord:
assumes "red F p q"
shows "q ≺⇩p p"
proof -
from red_setE[OF assms] obtain f and t where "red_single p q f t" .
from red_single_ord[OF this] show "q ≺⇩p p" .
qed
lemma red_indI1:
assumes "f ∈ F" and "f ≠ 0" and "p ≠ 0" and adds: "lt f adds⇩t lt p"
shows "red F p (p - monom_mult (lc p / lc f) (lp p - lp f) f)"
proof (intro red_setI[OF ‹f ∈ F›])
let ?s = "lp p - lp f"
have c: "lookup p (?s ⊕ lt f) = lc p" unfolding lc_def
by (metis add_diff_cancel_right' adds adds_termE pp_of_term_splus)
show "red_single p (p - monom_mult (lc p / lc f) ?s f) f ?s" unfolding red_single_def
proof (intro conjI, fact)
from c lc_not_0[OF ‹p ≠ 0›] show "lookup p (?s ⊕ lt f) ≠ 0" by simp
next
from c show "p - monom_mult (lc p / lc f) ?s f = p - monom_mult (lookup p (?s ⊕ lt f) / lc f) ?s f"
by simp
qed
qed
lemma red_indI2:
assumes "p ≠ 0" and r: "red F (tail p) q"
shows "red F p (q + monomial (lc p) (lt p))"
proof -
from red_setE[OF r] obtain f t where "f ∈ F" and rs: "red_single (tail p) q f t" by auto
from rs have "f ≠ 0" and ct: "lookup (tail p) (t ⊕ lt f) ≠ 0"
and q: "q = tail p - monom_mult (lookup (tail p) (t ⊕ lt f) / lc f) t f"
unfolding red_single_def by simp_all
from ct lookup_tail[of p "t ⊕ lt f"] have "t ⊕ lt f ≺⇩t lt p" by (auto split: if_splits)
hence c: "lookup (tail p) (t ⊕ lt f) = lookup p (t ⊕ lt f)" using lookup_tail[of p] by simp
show ?thesis
proof (intro red_setI[OF ‹f ∈ F›])
show "red_single p (q + Poly_Mapping.single (lt p) (lc p)) f t" unfolding red_single_def
proof (intro conjI, fact)
from ct c show "lookup p (t ⊕ lt f) ≠ 0" by simp
next
from q have "q + monomial (lc p) (lt p) =
(monomial (lc p) (lt p) + tail p) - monom_mult (lookup (tail p) (t ⊕ lt f) / lc f) t f"
by simp
also have "… = p - monom_mult (lookup (tail p) (t ⊕ lt f) / lc f) t f"
using leading_monomial_tail[of p] by auto
finally show "q + monomial (lc p) (lt p) = p - monom_mult (lookup p (t ⊕ lt f) / lc f) t f"
by (simp only: c)
qed
qed
qed
lemma red_indE:
assumes "red F p q"
shows "(∃f∈F. f ≠ 0 ∧ lt f adds⇩t lt p ∧
(q = p - monom_mult (lc p / lc f) (lp p - lp f) f)) ∨
red F (tail p) (q - monomial (lc p) (lt p))"
proof -
from red_nonzero[OF assms] have "p ≠ 0" .
from red_setE[OF assms] obtain f t where "f ∈ F" and rs: "red_single p q f t" by auto
from rs have "f ≠ 0"
and cn0: "lookup p (t ⊕ lt f) ≠ 0"
and q: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f"
unfolding red_single_def by simp_all
show ?thesis
proof (cases "lt p = t ⊕ lt f")
case True
hence "lt f adds⇩t lt p" by (simp add: term_simps)
from True have eq1: "lp p - lp f = t" by (simp add: term_simps)
from True have eq2: "lc p = lookup p (t ⊕ lt f)" unfolding lc_def by simp
show ?thesis
proof (intro disjI1, rule bexI[of _ f], intro conjI, fact+)
from q eq1 eq2 show "q = p - monom_mult (lc p / lc f) (lp p - lp f) f"
by simp
qed (fact)
next
case False
from this lookup_tail_2[of p "t ⊕ lt f"]
have ct: "lookup (tail p) (t ⊕ lt f) = lookup p (t ⊕ lt f)" by simp
show ?thesis
proof (intro disjI2, intro red_setI[of f], fact)
show "red_single (tail p) (q - monomial (lc p) (lt p)) f t" unfolding red_single_def
proof (intro conjI, fact)
from cn0 ct show "lookup (tail p) (t ⊕ lt f) ≠ 0" by simp
next
from leading_monomial_tail[of p]
have "p - monomial (lc p) (lt p) = (monomial (lc p) (lt p) + tail p) - monomial (lc p) (lt p)"
by simp
also have "… = tail p" by simp
finally have eq: "p - monomial (lc p) (lt p) = tail p" .
from q have "q - monomial (lc p) (lt p) =
(p - monomial (lc p) (lt p)) - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" by simp
also from eq have "… = tail p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f" by simp
finally show "q - monomial (lc p) (lt p) = tail p - monom_mult (lookup (tail p) (t ⊕ lt f) / lc f) t f"
using ct by simp
qed
qed
qed
qed
lemma is_redI:
assumes "red F a b"
shows "is_red F a"
unfolding is_red_def relation.is_final_def by (simp, intro exI[of _ b], fact)
lemma is_redE:
assumes "is_red F a"
obtains b where "red F a b"
using assms unfolding is_red_def relation.is_final_def
proof simp
assume r: "⋀b. red F a b ⟹ thesis" and b: "∃x. red F a x"
from b obtain b where "red F a b" ..
show thesis by (rule r[of b], fact)
qed
lemma is_red_alt:
shows "is_red F a ⟷ (∃b. red F a b)"
proof
assume "is_red F a"
from is_redE[OF this] obtain b where "red F a b" .
show "∃b. red F a b" by (intro exI[of _ b], fact)
next
assume "∃b. red F a b"
from this obtain b where "red F a b" ..
show "is_red F a" by (rule is_redI, fact)
qed
lemma is_red_singletonI:
assumes "is_red F q"
obtains p where "p ∈ F" and "is_red {p} q"
proof -
from assms obtain q0 where "red F q q0" unfolding is_red_alt ..
from this red_def[of F q q0] obtain p where "p ∈ F" and t: "∃t. red_single q q0 p t" by auto
have "is_red {p} q" unfolding is_red_alt
proof
from red_singleton[of p q q0] t show "red {p} q q0" by simp
qed
from ‹p ∈ F› this show ?thesis ..
qed
lemma is_red_singletonD:
assumes "is_red {p} q" and "p ∈ F"
shows "is_red F q"
proof -
from assms(1) obtain q0 where "red {p} q q0" unfolding is_red_alt ..
from red_singleton[of p q q0] this have "∃t. red_single q q0 p t" ..
from this obtain t where "red_single q q0 p t" ..
show ?thesis unfolding is_red_alt
by (intro exI[of _ q0], intro red_setI[OF assms(2), of q q0 t], fact)
qed
lemma is_red_singleton_trans:
assumes "is_red {f} p" and "lt g adds⇩t lt f" and "g ≠ 0"
shows "is_red {g} p"
proof -
from ‹is_red {f} p› obtain q where "red {f} p q" unfolding is_red_alt ..
from this red_singleton[of f p q] obtain t where "red_single p q f t" by auto
from red_single_trans[OF this assms(2, 3)] obtain q0 where
"red_single p q0 g (t + (lp f - lp g))" .
show ?thesis
proof (rule is_redI[of "{g}" p q0])
show "red {g} p q0" unfolding red_def
by (intro bexI[of _ g], intro exI[of _ "t + (lp f - lp g)"], fact, simp)
qed
qed
lemma is_red_singleton_not_0:
assumes "is_red {f} p"
shows "f ≠ 0"
using assms unfolding is_red_alt
proof
fix q
assume "red {f} p q"
from this red_singleton[of f p q] obtain t where "red_single p q f t" by auto
thus ?thesis unfolding red_single_def ..
qed
lemma irred_0:
shows "¬ is_red F 0"
proof (rule, rule is_redE)
fix b
assume "red F 0 b"
from ord_p_zero_min[of b] red_ord[OF this] show False by simp
qed
lemma is_red_indI1:
assumes "f ∈ F" and "f ≠ 0" and "p ≠ 0" and "lt f adds⇩t lt p"
shows "is_red F p"
by (intro is_redI, rule red_indI1[OF assms])
lemma is_red_indI2:
assumes "p ≠ 0" and "is_red F (tail p)"
shows "is_red F p"
proof -
from is_redE[OF ‹is_red F (tail p)›] obtain q where "red F (tail p) q" .
show ?thesis by (intro is_redI, rule red_indI2[OF ‹p ≠ 0›], fact)
qed
lemma is_red_indE:
assumes "is_red F p"
shows "(∃f∈F. f ≠ 0 ∧ lt f adds⇩t lt p) ∨ is_red F (tail p)"
proof -
from is_redE[OF assms] obtain q where "red F p q" .
from red_indE[OF this] show ?thesis
proof
assume "∃f∈F. f ≠ 0 ∧ lt f adds⇩t lt p ∧ q = p - monom_mult (lc p / lc f) (lp p - lp f) f"
from this obtain f where "f ∈ F" and "f ≠ 0" and "lt f adds⇩t lt p" by auto
show ?thesis by (intro disjI1, rule bexI[of _ f], intro conjI, fact+)
next
assume "red F (tail p) (q - monomial (lc p) (lt p))"
show ?thesis by (intro disjI2, intro is_redI, fact)
qed
qed
lemma rtrancl_0:
assumes "(red F)⇧*⇧* 0 x"
shows "x = 0"
proof -
from irred_0[of F] have "relation.is_final (red F) 0" unfolding is_red_def by simp
from relation.rtrancl_is_final[OF ‹(red F)⇧*⇧* 0 x› this] show ?thesis by simp
qed
lemma red_rtrancl_ord:
assumes "(red F)⇧*⇧* p q"
shows "q ≼⇩p p"
using assms
proof induct
case base
show ?case ..
next
case (step y z)
from step(2) have "z ≺⇩p y" by (rule red_ord)
hence "z ≼⇩p y" by simp
also note step(3)
finally show ?case .
qed
lemma components_red_subset:
assumes "red F p q"
shows "component_of_term ` keys q ⊆ component_of_term ` keys p ∪ component_of_term ` Keys F"
proof -
from assms obtain f t where "f ∈ F" and "red_single p q f t" by (rule red_setE)
from this(2) have q: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f"
by (simp add: red_single_def)
have "component_of_term ` keys q ⊆
component_of_term ` (keys p ∪ keys (monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f))"
by (rule image_mono, simp add: q keys_minus)
also have "... ⊆ component_of_term ` keys p ∪ component_of_term ` Keys F"
proof (simp add: image_Un, rule)
fix k
assume "k ∈ component_of_term ` keys (monom_mult (lookup p (t ⊕ lt f) / lc f) t f)"
then obtain v where "v ∈ keys (monom_mult (lookup p (t ⊕ lt f) / lc f) t f)"
and "k = component_of_term v" ..
from this(1) keys_monom_mult_subset have "v ∈ (⊕) t ` keys f" ..
then obtain u where "u ∈ keys f" and "v = t ⊕ u" ..
have "k = component_of_term u" by (simp add: ‹k = component_of_term v› ‹v = t ⊕ u› term_simps)
with ‹u ∈ keys f› have "k ∈ component_of_term ` keys f" by fastforce
also have "... ⊆ component_of_term ` Keys F" by (rule image_mono, rule keys_subset_Keys, fact)
finally show "k ∈ component_of_term ` keys p ∪ component_of_term ` Keys F" by simp
qed
finally show ?thesis .
qed
corollary components_red_rtrancl_subset:
assumes "(red F)⇧*⇧* p q"
shows "component_of_term ` keys q ⊆ component_of_term ` keys p ∪ component_of_term ` Keys F"
using assms
proof (induct)
case base
show ?case by simp
next
case (step q r)
from step(2) have "component_of_term ` keys r ⊆ component_of_term ` keys q ∪ component_of_term ` Keys F"
by (rule components_red_subset)
also from step(3) have "... ⊆ component_of_term ` keys p ∪ component_of_term ` Keys F" by blast
finally show ?case .
qed
subsection ‹Reducibility and Addition \& Multiplication›
lemma red_single_monom_mult:
assumes "red_single p q f t" and "c ≠ 0"
shows "red_single (monom_mult c s p) (monom_mult c s q) f (s + t)"
proof -
from assms(1) have "f ≠ 0"
and "lookup p (t ⊕ lt f) ≠ 0"
and q_def: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f"
unfolding red_single_def by auto
have assoc: "(s + t) ⊕ lt f = s ⊕ (t ⊕ lt f)" by (simp add: ac_simps)
have g2: "lookup (monom_mult c s p) ((s + t) ⊕ lt f) ≠ 0"
proof
assume "lookup (monom_mult c s p) ((s + t) ⊕ lt f) = 0"
hence "c * lookup p (t ⊕ lt f) = 0" using assoc by (simp add: lookup_monom_mult_plus)
thus False using ‹c ≠ 0› ‹lookup p (t ⊕ lt f) ≠ 0› by simp
qed
have g3: "monom_mult c s q =
(monom_mult c s p) - monom_mult ((lookup (monom_mult c s p) ((s + t) ⊕ lt f)) / lc f) (s + t) f"
proof -
from q_def monom_mult_dist_right_minus[of c s p]
have "monom_mult c s q =
monom_mult c s p - monom_mult c s (monom_mult (lookup p (t ⊕ lt f) / lc f) t f)" by simp
also from monom_mult_assoc[of c s "lookup p (t ⊕ lt f) / lc f" t f] assoc
have "monom_mult c s (monom_mult (lookup p (t ⊕ lt f) / lc f) t f) =
monom_mult ((lookup (monom_mult c s p) ((s + t) ⊕ lt f)) / lc f) (s + t) f"
by (simp add: lookup_monom_mult_plus)
finally show ?thesis .
qed
from ‹f ≠ 0› g2 g3 show ?thesis unfolding red_single_def by auto
qed
lemma red_single_plus_1:
assumes "red_single p q f t" and "t ⊕ lt f ∉ keys (p + r)"
shows "red_single (q + r) (p + r) f t"
proof -
from assms have "f ≠ 0" and "lookup p (t ⊕ lt f) ≠ 0"
and q: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f"
by (simp_all add: red_single_def)
from assms(1) have cq_0: "lookup q (t ⊕ lt f) = 0" by (rule red_single_lookup)
from assms(2) have "lookup (p + r) (t ⊕ lt f) = 0"
by (simp add: in_keys_iff)
with neg_eq_iff_add_eq_0[of "lookup p (t ⊕ lt f)" "lookup r (t ⊕ lt f)"]
have cr: "lookup r (t ⊕ lt f) = - (lookup p (t ⊕ lt f))" by (simp add: lookup_add)
hence cr_not_0: "lookup r (t ⊕ lt f) ≠ 0" using ‹lookup p (t ⊕ lt f) ≠ 0› by simp
from ‹f ≠ 0› show ?thesis unfolding red_single_def
proof (intro conjI)
from cr_not_0 show "lookup (q + r) (t ⊕ lt f) ≠ 0" by (simp add: lookup_add cq_0)
next
from lc_not_0[OF ‹f ≠ 0›]
have "monom_mult ((lookup (q + r) (t ⊕ lt f)) / lc f) t f =
monom_mult ((lookup r (t ⊕ lt f)) / lc f) t f"
by (simp add: field_simps lookup_add cq_0)
thus "p + r = q + r - monom_mult (lookup (q + r) (t ⊕ lt f) / lc f) t f"
by (simp add: cr q monom_mult_uminus_left)
qed
qed
lemma red_single_plus_2:
assumes "red_single p q f t" and "t ⊕ lt f ∉ keys (q + r)"
shows "red_single (p + r) (q + r) f t"
proof -
from assms have "f ≠ 0" and cp: "lookup p (t ⊕ lt f) ≠ 0"
and q: "q = p - monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f"
by (simp_all add: red_single_def)
from assms(1) have cq_0: "lookup q (t ⊕ lt f) = 0" by (rule red_single_lookup)
with assms(2) have cr_0: "lookup r (t ⊕ lt f) = 0"
by (simp add: lookup_add in_keys_iff)
from ‹f ≠ 0› show ?thesis unfolding red_single_def
proof (intro conjI)
from cp show "lookup (p + r) (t ⊕ lt f) ≠ 0" by (simp add: lookup_add cr_0)
next
show "q + r = p + r - monom_mult (lookup (p + r) (t ⊕ lt f) / lc f) t f"
by (simp add: cr_0 q lookup_add)
qed
qed
lemma red_single_plus_3:
assumes "red_single p q f t" and "t ⊕ lt f ∈ keys (p + r)" and "t ⊕ lt f ∈ keys (q + r)"
shows "∃s. red_single (p + r) s f t ∧ red_single (q + r) s f t"
proof -
let ?t = "t ⊕ lt f"
from assms have "f ≠ 0" and "lookup p ?t ≠ 0"
and q: "q = p - monom_mult ((lookup p ?t) / lc f) t f"
by (simp_all add: red_single_def)
from assms(2) have cpr: "lookup (p + r) ?t ≠ 0" by (simp add: in_keys_iff)
from assms(3) have cqr: "lookup (q + r) ?t ≠ 0" by (simp add: in_keys_iff)
from assms(1) have cq_0: "lookup q ?t = 0" by (rule red_single_lookup)
let ?s = "(p + r) - monom_mult ((lookup (p + r) ?t) / lc f) t f"
from ‹f ≠ 0› cpr have "red_single (p + r) ?s f t" by (simp add: red_single_def)
moreover from ‹f ≠ 0› have "red_single (q + r) ?s f t" unfolding red_single_def
proof (intro conjI)
from cqr show "lookup (q + r) ?t ≠ 0" .
next
from lc_not_0[OF ‹f ≠ 0›]
monom_mult_dist_left[of "(lookup p ?t) / lc f" "(lookup r ?t) / lc f" t f]
have "monom_mult ((lookup (p + r) ?t) / lc f) t f =
(monom_mult ((lookup p ?t) / lc f) t f) +
(monom_mult ((lookup r ?t) / lc f) t f)"
by (simp add: field_simps lookup_add)
moreover from lc_not_0[OF ‹f ≠ 0›]
monom_mult_dist_left[of "(lookup q ?t) / lc f" "(lookup r ?t) / lc f" t f]
have "monom_mult ((lookup (q + r) ?t) / lc f) t f =
monom_mult ((lookup r ?t) / lc f) t f"
by (simp add: field_simps lookup_add cq_0)
ultimately show "p + r - monom_mult (lookup (p + r) ?t / lc f) t f =
q + r - monom_mult (lookup (q + r) ?t / lc f) t f" by (simp add: q)
qed
ultimately show ?thesis by auto
qed
lemma red_single_plus:
assumes "red_single p q f t"
shows "red_single (p + r) (q + r) f t ∨
red_single (q + r) (p + r) f t ∨
(∃s. red_single (p + r) s f t ∧ red_single (q + r) s f t)" (is "?A ∨ ?B ∨ ?C")
proof (cases "t ⊕ lt f ∈ keys (p + r)")
case True
show ?thesis
proof (cases "t ⊕ lt f ∈ keys (q + r)")
case True
with assms ‹t ⊕ lt f ∈ keys (p + r)› have ?C by (rule red_single_plus_3)
thus ?thesis by simp
next
case False
with assms have ?A by (rule red_single_plus_2)
thus ?thesis ..
qed
next
case False
with assms have ?B by (rule red_single_plus_1)
thus ?thesis by simp
qed
lemma red_single_diff:
assumes "red_single (p - q) r f t"
shows "red_single p (r + q) f t ∨ red_single q (p - r) f t ∨
(∃p' q'. red_single p p' f t ∧ red_single q q' f t ∧ r = p' - q')" (is "?A ∨ ?B ∨ ?C")
proof -
let ?s = "t ⊕ lt f"
from assms have "f ≠ 0"
and "lookup (p - q) ?s ≠ 0"
and r: "r = p - q - monom_mult ((lookup (p - q) ?s) / lc f) t f"
unfolding red_single_def by auto
from this(2) have diff: "lookup p ?s ≠ lookup q ?s" by (simp add: lookup_minus)
show ?thesis
proof (cases "lookup p ?s = 0")
case True
with diff have "?s ∈ keys q" by (simp add: in_keys_iff)
moreover have "lookup (p - q) ?s = - lookup q ?s" by (simp add: lookup_minus True)
ultimately have ?B using ‹f ≠ 0› by (simp add: in_keys_iff red_single_def r monom_mult_uminus_left)
thus ?thesis by simp
next
case False
hence "?s ∈ keys p" by (simp add: in_keys_iff)
show ?thesis
proof (cases "lookup q ?s = 0")
case True
hence "lookup (p - q) ?s = lookup p ?s" by (simp add: lookup_minus)
hence ?A using ‹f ≠ 0› ‹?s ∈ keys p› by (simp add: in_keys_iff red_single_def r monom_mult_uminus_left)
thus ?thesis ..
next
case False
hence "?s ∈ keys q" by (simp add: in_keys_iff)
let ?p = "p - monom_mult ((lookup p ?s) / lc f) t f"
let ?q = "q - monom_mult ((lookup q ?s) / lc f) t f"
have ?C
proof (intro exI conjI)
from ‹f ≠ 0› ‹?s ∈ keys p› show "red_single p ?p f t" by (simp add: in_keys_iff red_single_def)
next
from ‹f ≠ 0› ‹?s ∈ keys q› show "red_single q ?q f t" by (simp add: in_keys_iff red_single_def)
next
from ‹f ≠ 0› have "lc f ≠ 0" by (rule lc_not_0)
hence eq: "(lookup p ?s - lookup q ?s) / lc f =
lookup p ?s / lc f - lookup q ?s / lc f" by (simp add: field_simps)
show "r = ?p - ?q" by (simp add: r lookup_minus eq monom_mult_dist_left_minus)
qed
thus ?thesis by simp
qed
qed
qed
lemma red_monom_mult:
assumes a: "red F p q" and "c ≠ 0"
shows "red F (monom_mult c s p) (monom_mult c s q)"
proof -
from red_setE[OF a] obtain f and t where "f ∈ F" and rs: "red_single p q f t" by auto
from red_single_monom_mult[OF rs ‹c ≠ 0›, of s] show ?thesis by (intro red_setI[OF ‹f ∈ F›])
qed
lemma red_plus_keys_disjoint:
assumes "red F p q" and "keys p ∩ keys r = {}"
shows "red F (p + r) (q + r)"
proof -
from assms(1) obtain f t where "f ∈ F" and *: "red_single p q f t" by (rule red_setE)
from this(2) have "red_single (p + r) (q + r) f t"
proof (rule red_single_plus_2)
from * have "lookup q (t ⊕ lt f) = 0"
by (simp add: red_single_def lookup_minus lookup_monom_mult lc_def[symmetric] lc_not_0 term_simps)
hence "t ⊕ lt f ∉ keys q" by (simp add: in_keys_iff)
moreover have "t ⊕ lt f ∉ keys r"
proof
assume "t ⊕ lt f ∈ keys r"
moreover from * have "t ⊕ lt f ∈ keys p" by (simp add: in_keys_iff red_single_def)
ultimately have "t ⊕ lt f ∈ keys p ∩ keys r" by simp
with assms(2) show False by simp
qed
ultimately have "t ⊕ lt f ∉ keys q ∪ keys r" by simp
thus "t ⊕ lt f ∉ keys (q + r)"
by (meson Poly_Mapping.keys_add subsetD)
qed
with ‹f ∈ F› show ?thesis by (rule red_setI)
qed
lemma red_plus:
assumes "red F p q"
obtains s where "(red F)⇧*⇧* (p + r) s" and "(red F)⇧*⇧* (q + r) s"
proof -
from red_setE[OF assms] obtain f and t where "f ∈ F" and rs: "red_single p q f t" by auto
from red_single_plus[OF rs, of r] show ?thesis
proof
assume c1: "red_single (p + r) (q + r) f t"
show ?thesis
proof
from c1 show "(red F)⇧*⇧* (p + r) (q + r)" by (intro r_into_rtranclp, intro red_setI[OF ‹f ∈ F›])
next
show "(red F)⇧*⇧* (q + r) (q + r)" ..
qed
next
assume "red_single (q + r) (p + r) f t ∨ (∃s. red_single (p + r) s f t ∧ red_single (q + r) s f t)"
thus ?thesis
proof
assume c2: "red_single (q + r) (p + r) f t"
show ?thesis
proof
show "(red F)⇧*⇧* (p + r) (p + r)" ..
next
from c2 show "(red F)⇧*⇧* (q + r) (p + r)" by (intro r_into_rtranclp, intro red_setI[OF ‹f ∈ F›])
qed
next
assume "∃s. red_single (p + r) s f t ∧ red_single (q + r) s f t"
then obtain s where s1: "red_single (p + r) s f t" and s2: "red_single (q + r) s f t" by auto
show ?thesis
proof
from s1 show "(red F)⇧*⇧* (p + r) s" by (intro r_into_rtranclp, intro red_setI[OF ‹f ∈ F›])
next
from s2 show "(red F)⇧*⇧* (q + r) s" by (intro r_into_rtranclp, intro red_setI[OF ‹f ∈ F›])
qed
qed
qed
qed
corollary red_plus_cs:
assumes "red F p q"
shows "relation.cs (red F) (p + r) (q + r)"
unfolding relation.cs_def
proof -
from assms obtain s where "(red F)⇧*⇧* (p + r) s" and "(red F)⇧*⇧* (q + r) s" by (rule red_plus)
show "∃s. (red F)⇧*⇧* (p + r) s ∧ (red F)⇧*⇧* (q + r) s" by (intro exI, intro conjI, fact, fact)
qed
lemma red_uminus:
assumes "red F p q"
shows "red F (-p) (-q)"
using red_monom_mult[OF assms, of "-1" 0] by (simp add: uminus_monom_mult)
lemma red_diff:
assumes "red F (p - q) r"
obtains p' q' where "(red F)⇧*⇧* p p'" and "(red F)⇧*⇧* q q'" and "r = p' - q'"
proof -
from assms obtain f t where "f ∈ F" and "red_single (p - q) r f t" by (rule red_setE)
from red_single_diff[OF this(2)] show ?thesis
proof (elim disjE)
assume "red_single p (r + q) f t"
with ‹f ∈ F› have *: "red F p (r + q)" by (rule red_setI)
show ?thesis
proof
from * show "(red F)⇧*⇧* p (r + q)" ..
next
show "(red F)⇧*⇧* q q" ..
qed simp
next
assume "red_single q (p - r) f t"
with ‹f ∈ F› have *: "red F q (p - r)" by (rule red_setI)
show ?thesis
proof
show "(red F)⇧*⇧* p p" ..
next
from * show "(red F)⇧*⇧* q (p - r)" ..
qed simp
next
assume "∃p' q'. red_single p p' f t ∧ red_single q q' f t ∧ r = p' - q'"
then obtain p' q' where 1: "red_single p p' f t" and 2: "red_single q q' f t" and "r = p' - q'"
by blast
from ‹f ∈ F› 2 have "red F q q'" by (rule red_setI)
from ‹f ∈ F› 1 have "red F p p'" by (rule red_setI)
hence "(red F)⇧*⇧* p p'" ..
moreover from ‹red F q q'› have "(red F)⇧*⇧* q q'" ..
moreover note ‹r = p' - q'›
ultimately show ?thesis ..
qed
qed
lemma red_diff_rtrancl':
assumes "(red F)⇧*⇧* (p - q) r"
obtains p' q' where "(red F)⇧*⇧* p p'" and "(red F)⇧*⇧* q q'" and "r = p' - q'"
using assms
proof (induct arbitrary: thesis rule: rtranclp_induct)
case base
show ?case by (rule base, fact rtrancl_refl[to_pred], fact rtrancl_refl[to_pred], fact refl)
next
case (step y z)
obtain p1 q1 where p1: "(red F)⇧*⇧* p p1" and q1: "(red F)⇧*⇧* q q1" and y: "y = p1 - q1" by (rule step(3))
from step(2) obtain p' q' where p': "(red F)⇧*⇧* p1 p'" and q': "(red F)⇧*⇧* q1 q'" and z: "z = p' - q'"
unfolding y by (rule red_diff)
show ?case
proof (rule step(4))
from p1 p' show "(red F)⇧*⇧* p p'" by simp
next
from q1 q' show "(red F)⇧*⇧* q q'" by simp
qed fact
qed
lemma red_diff_rtrancl:
assumes "(red F)⇧*⇧* (p - q) 0"
obtains s where "(red F)⇧*⇧* p s" and "(red F)⇧*⇧* q s"
proof -
from assms obtain p' q' where p': "(red F)⇧*⇧* p p'" and q': "(red F)⇧*⇧* q q'" and "0 = p' - q'"
by (rule red_diff_rtrancl')
from this(3) have "q' = p'" by simp
from p' q' show ?thesis unfolding ‹q' = p'› ..
qed
corollary red_diff_rtrancl_cs:
assumes "(red F)⇧*⇧* (p - q) 0"
shows "relation.cs (red F) p q"
unfolding relation.cs_def
proof -
from assms obtain s where "(red F)⇧*⇧* p s" and "(red F)⇧*⇧* q s" by (rule red_diff_rtrancl)
show "∃s. (red F)⇧*⇧* p s ∧ (red F)⇧*⇧* q s" by (intro exI, intro conjI, fact, fact)
qed
subsection ‹Confluence of Reducibility›
lemma confluent_distinct_aux:
assumes r1: "red_single p q1 f1 t1" and r2: "red_single p q2 f2 t2"
and "t1 ⊕ lt f1 ≺⇩t t2 ⊕ lt f2" and "f1 ∈ F" and "f2 ∈ F"
obtains s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s"
proof -
from r1 have "f1 ≠ 0" and c1: "lookup p (t1 ⊕ lt f1) ≠ 0"
and q1_def: "q1 = p - monom_mult (lookup p (t1 ⊕ lt f1) / lc f1) t1 f1"
unfolding red_single_def by auto
from r2 have "f2 ≠ 0" and c2: "lookup p (t2 ⊕ lt f2) ≠ 0"
and q2_def: "q2 = p - monom_mult (lookup p (t2 ⊕ lt f2) / lc f2) t2 f2"
unfolding red_single_def by auto
from ‹t1 ⊕ lt f1 ≺⇩t t2 ⊕ lt f2›
have "lookup (monom_mult (lookup p (t1 ⊕ lt f1) / lc f1) t1 f1) (t2 ⊕ lt f2) = 0"
by (simp add: lookup_monom_mult_eq_zero)
from lookup_minus[of p _ "t2 ⊕ lt f2"] this have c: "lookup q1 (t2 ⊕ lt f2) = lookup p (t2 ⊕ lt f2)"
unfolding q1_def by simp
define q3 where "q3 ≡ q1 - monom_mult ((lookup q1 (t2 ⊕ lt f2)) / lc f2) t2 f2"
have "red_single q1 q3 f2 t2" unfolding red_single_def
proof (rule, fact, rule)
from c c2 show "lookup q1 (t2 ⊕ lt f2) ≠ 0" by simp
next
show "q3 = q1 - monom_mult (lookup q1 (t2 ⊕ lt f2) / lc f2) t2 f2" unfolding q3_def ..
qed
hence "red F q1 q3" by (intro red_setI[OF ‹f2 ∈ F›])
hence q1q3: "(red F)⇧*⇧* q1 q3" by (intro r_into_rtranclp)
from r1 have "red F p q1" by (intro red_setI[OF ‹f1 ∈ F›])
from red_plus[OF this, of "- monom_mult ((lookup p (t2 ⊕ lt f2)) / lc f2) t2 f2"] obtain s
where r3: "(red F)⇧*⇧* (p - monom_mult (lookup p (t2 ⊕ lt f2) / lc f2) t2 f2) s"
and r4: "(red F)⇧*⇧* (q1 - monom_mult (lookup p (t2 ⊕ lt f2) / lc f2) t2 f2) s" by auto
from r3 have q2s: "(red F)⇧*⇧* q2 s" unfolding q2_def by simp
from r4 c have q3s: "(red F)⇧*⇧* q3 s" unfolding q3_def by simp
show ?thesis
proof
from rtranclp_trans[OF q1q3 q3s] show "(red F)⇧*⇧* q1 s" .
next
from q2s show "(red F)⇧*⇧* q2 s" .
qed
qed
lemma confluent_distinct:
assumes r1: "red_single p q1 f1 t1" and r2: "red_single p q2 f2 t2"
and ne: "t1 ⊕ lt f1 ≠ t2 ⊕ lt f2" and "f1 ∈ F" and "f2 ∈ F"
obtains s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s"
proof -
from ne have "t1 ⊕ lt f1 ≺⇩t t2 ⊕ lt f2 ∨ t2 ⊕ lt f2 ≺⇩t t1 ⊕ lt f1" by auto
thus ?thesis
proof
assume a1: "t1 ⊕ lt f1 ≺⇩t t2 ⊕ lt f2"
from confluent_distinct_aux[OF r1 r2 a1 ‹f1 ∈ F› ‹f2 ∈ F›] obtain s where
"(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s" .
thus ?thesis ..
next
assume a2: "t2 ⊕ lt f2 ≺⇩t t1 ⊕ lt f1"
from confluent_distinct_aux[OF r2 r1 a2 ‹f2 ∈ F› ‹f1 ∈ F›] obtain s where
"(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s" .
thus ?thesis ..
qed
qed
corollary confluent_same:
assumes r1: "red_single p q1 f t1" and r2: "red_single p q2 f t2" and "f ∈ F"
obtains s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s"
proof (cases "t1 = t2")
case True
with r1 r2 have "q1 = q2" by (simp add: red_single_def)
show ?thesis
proof
show "(red F)⇧*⇧* q1 q2" unfolding ‹q1 = q2› ..
next
show "(red F)⇧*⇧* q2 q2" ..
qed
next
case False
hence "t1 ⊕ lt f ≠ t2 ⊕ lt f" by (simp add: term_simps)
from r1 r2 this ‹f ∈ F› ‹f ∈ F› obtain s where "(red F)⇧*⇧* q1 s" and "(red F)⇧*⇧* q2 s"
by (rule confluent_distinct)
thus ?thesis ..
qed
subsection ‹Reducibility and Module Membership›
lemma srtc_in_pmdl:
assumes "relation.srtc (red F) p q"
shows "p - q ∈ pmdl F"
using assms unfolding relation.srtc_def
proof (induct rule: rtranclp.induct)
fix p
show "p - p ∈ pmdl F" by (simp add: pmdl.span_zero)
next
fix p r q
assume pr_in: "p - r ∈ pmdl F" and red: "red F r q ∨ red F q r"
from red obtain f c t where "f ∈ F" and "q = r - monom_mult c t f"
proof
assume "red F r q"
from red_setE[OF this] obtain f t where "f ∈ F" and "red_single r q f t" .
hence "q = r - monom_mult (lookup r (t ⊕ lt f) / lc f) t f" by (simp add: red_single_def)
show thesis by (rule, fact, fact)
next
assume "red F q r"
from red_setE[OF this] obtain f t where "f ∈ F" and "red_single q r f t" .
hence "r = q - monom_mult (lookup q (t ⊕ lt f) / lc f) t f" by (simp add: red_single_def)
hence "q = r + monom_mult (lookup q (t ⊕ lt f) / lc f) t f" by simp
hence "q = r - monom_mult (-(lookup q (t ⊕ lt f) / lc f)) t f"
using monom_mult_uminus_left[of _ t f] by simp
show thesis by (rule, fact, fact)
qed
hence eq: "p - q = (p - r) + monom_mult c t f" by simp
show "p - q ∈ pmdl F" unfolding eq
by (rule pmdl.span_add, fact, rule monom_mult_in_pmdl, fact)
qed
lemma in_pmdl_srtc:
assumes "p ∈ pmdl F"
shows "relation.srtc (red F) p 0"
using assms
proof (induct p rule: pmdl_induct)
show "relation.srtc (red F) 0 0" unfolding relation.srtc_def ..
next
fix a f c t
assume a_in: "a ∈ pmdl F" and IH: "relation.srtc (red F) a 0" and "f ∈ F"
show "relation.srtc (red F) (a + monom_mult c t f) 0"
proof (cases "c = 0")
assume "c = 0"
hence "a + monom_mult c t f = a" by simp
thus ?thesis using IH by simp
next
assume "c ≠ 0"
show ?thesis
proof (cases "f = 0")
assume "f = 0"
hence "a + monom_mult c t f = a" by simp
thus ?thesis using IH by simp
next
assume "f ≠ 0"
from lc_not_0[OF this] have "lc f ≠ 0" .
have "red F (monom_mult c t f) 0"
proof (intro red_setI[OF ‹f ∈ F›])
from lookup_monom_mult_plus[of c t f "lt f"]
have eq: "lookup (monom_mult c t f) (t ⊕ lt f) = c * lc f" unfolding lc_def .
show "red_single (monom_mult c t f) 0 f t" unfolding red_single_def eq
proof (intro conjI, fact)
from ‹c ≠ 0› ‹lc f ≠ 0› show "c * lc f ≠ 0" by simp
next
from ‹lc f ≠ 0› show "0 = monom_mult c t f - monom_mult (c * lc f / lc f) t f" by simp
qed
qed
from red_plus[OF this, of a] obtain s where
s1: "(red F)⇧*⇧* (monom_mult c t f + a) s" and s2: "(red F)⇧*⇧* (0 + a) s" .
have "relation.cs (red F) (a + monom_mult c t f) a" unfolding relation.cs_def
proof (intro exI[of _ s], intro conjI)
from s1 show "(red F)⇧*⇧* (a + monom_mult c t f) s" by (simp only: add.commute)
next
from s2 show "(red F)⇧*⇧* a s" by simp
qed
from relation.srtc_transitive[OF relation.cs_implies_srtc[OF this] IH] show ?thesis .
qed
qed
qed
lemma red_rtranclp_diff_in_pmdl:
assumes "(red F)⇧*⇧* p q"
shows "p - q ∈ pmdl F"
proof -
from assms have "relation.srtc (red F) p q"
by (simp add: r_into_rtranclp relation.rtc_implies_srtc)
thus ?thesis by (rule srtc_in_pmdl)
qed
corollary red_diff_in_pmdl:
assumes "red F p q"
shows "p - q ∈ pmdl F"
by (rule red_rtranclp_diff_in_pmdl, rule r_into_rtranclp, fact)
corollary red_rtranclp_0_in_pmdl:
assumes "(red F)⇧*⇧* p 0"
shows "p ∈ pmdl F"
using assms red_rtranclp_diff_in_pmdl by fastforce
lemma pmdl_closed_red:
assumes "pmdl B ⊆ pmdl A" and "p ∈ pmdl A" and "red B p q"
shows "q ∈ pmdl A"
proof -
have "q - p ∈ pmdl A"
proof
have "p - q ∈ pmdl B" by (rule red_diff_in_pmdl, fact)
hence "- (p - q) ∈ pmdl B" by (rule pmdl.span_neg)
thus "q - p ∈ pmdl B" by simp
qed fact
from pmdl.span_add[OF this ‹p ∈ pmdl A›] show ?thesis by simp
qed
subsection ‹More Properties of @{const red}, @{const red_single} and @{const is_red}›
lemma red_rtrancl_mult:
assumes "(red F)⇧*⇧* p q"
shows "(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t q)"
proof (cases "c = 0")
case True
have "(red F)⇧*⇧* 0 0" by simp
thus ?thesis by (simp only: True monom_mult_zero_left)
next
case False
from assms show ?thesis
proof (induct rule: rtranclp_induct)
show "(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t p)" by simp
next
fix q0 q
assume "(red F)⇧*⇧* p q0" and "red F q0 q" and "(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t q0)"
show "(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t q)"
proof (rule rtranclp.intros(2)[OF ‹(red F)⇧*⇧* (monom_mult c t p) (monom_mult c t q0)›])
from red_monom_mult[OF ‹red F q0 q› False, of t] show "red F (monom_mult c t q0) (monom_mult c t q)" .
qed
qed
qed
corollary red_rtrancl_uminus:
assumes "(red F)⇧*⇧* p q"
shows "(red F)⇧*⇧* (-p) (-q)"
using red_rtrancl_mult[OF assms, of "-1" 0] by (simp add: uminus_monom_mult)
lemma red_rtrancl_diff_induct [consumes 1, case_names base step]:
assumes a: "(red F)⇧*⇧* (p - q) r"
and cases: "P p p" "!!y z. [| (red F)⇧*⇧* (p - q) z; red F z y; P p (q + z)|] ==> P p (q + y)"
shows "P p (q + r)"
using a
proof (induct rule: rtranclp_induct)
from cases(1) show "P p (q + (p - q))" by simp
next
fix y z
assume "(red F)⇧*⇧* (p - q) z" "red F z y" "P p (q + z)"
thus "P p (q + y)" using cases(2) by simp
qed
lemma red_rtrancl_diff_0_induct [consumes 1, case_names base step]:
assumes a: "(red F)⇧*⇧* (p - q) 0"
and base: "P p p" and ind: "⋀y z. [| (red F)⇧*⇧* (p - q) y; red F y z; P p (y + q)|] ==> P p (z + q)"
shows "P p q"
proof -
from ind red_rtrancl_diff_induct[of F p q 0 P, OF a base] have "P p (0 + q)"
by (simp add: ac_simps)
thus ?thesis by simp
qed
lemma is_red_union: "is_red (A ∪ B) p ⟷ (is_red A p ∨ is_red B p)"
unfolding is_red_alt red_union by auto
lemma red_single_0_lt:
assumes "red_single f 0 h t"
shows "lt f = t ⊕ lt h"
proof -
from red_single_nonzero1[OF assms] have "f ≠ 0" .
{
assume "h ≠ 0" and neq: "lookup f (t ⊕ lt h) ≠ 0" and
eq: "f = monom_mult (lookup f (t ⊕ lt h) / lc h) t h"
from lc_not_0[OF ‹h ≠ 0›] have "lc h ≠ 0" .
with neq have "(lookup f (t ⊕ lt h) / lc h) ≠ 0" by simp
from eq lt_monom_mult[OF this ‹h ≠ 0›, of t] have "lt f = t ⊕ lt h" by simp
hence "lt f = t ⊕ lt h" by (simp add: ac_simps)
}
with assms show ?thesis unfolding red_single_def by auto
qed
lemma red_single_lt_distinct_lt:
assumes rs: "red_single f g h t" and "g ≠ 0" and "lt g ≠ lt f"
shows "lt f = t ⊕ lt h"
proof -
from red_single_nonzero1[OF rs] have "f ≠ 0" .
from red_single_ord[OF rs] have "g ≼⇩p f" by simp
from ord_p_lt[OF this] ‹lt g ≠ lt f› have "lt g ≺⇩t lt f" by simp
{
assume "h ≠ 0" and neq: "lookup f (t ⊕ lt h) ≠ 0" and
eq: "f = g + monom_mult (lookup f (t ⊕ lt h) / lc h) t h" (is "f = g + ?R")
from lc_not_0[OF ‹h ≠ 0›] have "lc h ≠ 0" .
with neq have "(lookup f (t ⊕ lt h) / lc h) ≠ 0" (is "?c ≠ 0") by simp
from eq lt_monom_mult[OF this ‹h ≠ 0›, of t] have ltR: "lt ?R = t ⊕ lt h" by simp
from monom_mult_eq_zero_iff[of ?c t h] ‹?c ≠ 0› ‹h ≠ 0› have "?R ≠ 0" by auto
from lt_plus_lessE[of g] eq ‹lt g ≺⇩t lt f› have "lt g ≺⇩t lt ?R" by auto
from lt_plus_eqI[OF this] eq ltR have "lt f = t ⊕ lt h" by (simp add: ac_simps)
}
with assms show ?thesis unfolding red_single_def by auto
qed
lemma zero_reducibility_implies_lt_divisibility':
assumes "(red F)⇧*⇧* f 0" and "f ≠ 0"
shows "∃h∈F. h ≠ 0 ∧ (lt h adds⇩t lt f)"
using assms
proof (induct rule: converse_rtranclp_induct)
case base
then show ?case by simp
next
case (step f g)
show ?case
proof (cases "g = 0")
case True
with step.hyps have "red F f 0" by simp
from red_setE[OF this] obtain h t where "h ∈ F" and rs: "red_single f 0 h t" by auto
show ?thesis
proof
from red_single_0_lt[OF rs] have "lt h adds⇩t lt f" by (simp add: term_simps)
also from rs have "h ≠ 0" by (simp add: red_single_def)
ultimately show "h ≠ 0 ∧ lt h adds⇩t lt f" by simp
qed (rule ‹h ∈ F›)
next
case False
show ?thesis
proof (cases "lt g = lt f")
case True
with False step.hyps show ?thesis by simp
next
case False
from red_setE[OF ‹red F f g›] obtain h t where "h ∈ F" and rs: "red_single f g h t" by auto
show ?thesis
proof
from red_single_lt_distinct_lt[OF rs ‹g ≠ 0› False] have "lt h adds⇩t lt f"
by (simp add: term_simps)
also from rs have "h ≠ 0" by (simp add: red_single_def)
ultimately show "h ≠ 0 ∧ lt h adds⇩t lt f" by simp
qed (rule ‹h ∈ F›)
qed
qed
qed
lemma zero_reducibility_implies_lt_divisibility:
assumes "(red F)⇧*⇧* f 0" and "f ≠ 0"
obtains h where "h ∈ F" and "h ≠ 0" and "lt h adds⇩t lt f"
using zero_reducibility_implies_lt_divisibility'[OF assms] by auto
lemma is_red_addsI:
assumes "f ∈ F" and "f ≠ 0" and "v ∈ keys p" and "lt f adds⇩t v"
shows "is_red F p"
using assms
proof (induction p rule: poly_mapping_tail_induct)
case 0
from ‹v ∈ keys 0› show ?case by auto
next
case (tail p)
from "tail.IH"[OF ‹f ∈ F› ‹f ≠ 0› _ ‹lt f adds⇩t v›] have imp: "v ∈ keys (tail p) ⟹ is_red F (tail p)" .
show ?case
proof (cases "v = lt p")
case True
show ?thesis
proof (rule is_red_indI1[OF ‹f ∈ F› ‹f ≠ 0› ‹p ≠ 0›])
from ‹lt f adds⇩t v› True show "lt f adds⇩t lt p" by simp
qed
next
case False
with ‹v ∈ keys p› ‹p ≠ 0› have "v ∈ keys (tail p)"
by (simp add: lookup_tail_2 in_keys_iff)
from is_red_indI2[OF ‹p ≠ 0› imp[OF this]] show ?thesis .
qed
qed
lemma is_red_addsE':
assumes "is_red F p"
shows "∃f∈F. ∃v∈keys p. f ≠ 0 ∧ lt f adds⇩t v"
using assms
proof (induction p rule: poly_mapping_tail_induct)
case 0
with irred_0[of F] show ?case by simp
next
case (tail p)
from is_red_indE[OF ‹is_red F p›] show ?case
proof
assume "∃f∈F. f ≠ 0 ∧ lt f adds⇩t lt p"
then obtain f where "f ∈ F" and "f ≠ 0" and "lt f adds⇩t lt p" by auto
show ?case
proof
show "∃v∈keys p. f ≠ 0 ∧ lt f adds⇩t v"
proof (intro bexI, intro conjI)
from ‹p ≠ 0› show "lt p ∈ keys p" by (metis in_keys_iff lc_def lc_not_0)
qed (rule ‹f ≠ 0›, rule ‹lt f adds⇩t lt p›)
qed (rule ‹f ∈ F›)
next
assume "is_red F (tail p)"
from "tail.IH"[OF this] obtain f v
where "f ∈ F" and "f ≠ 0" and v_in_keys_tail: "v ∈ keys (tail p)" and "lt f adds⇩t v" by auto
from "tail.hyps" v_in_keys_tail have v_in_keys: "v ∈ keys p" by (metis lookup_tail in_keys_iff)
show ?case
proof
show "∃v∈keys p. f ≠ 0 ∧ lt f adds⇩t v"
by (intro bexI, intro conjI, rule ‹f ≠ 0›, rule ‹lt f adds⇩t v›, rule v_in_keys)
qed (rule ‹f ∈ F›)
qed
qed
lemma is_red_addsE:
assumes "is_red F p"
obtains f v where "f ∈ F" and "v ∈ keys p" and "f ≠ 0" and "lt f adds⇩t v"
using is_red_addsE'[OF assms] by auto
lemma is_red_adds_iff:
shows "(is_red F p) ⟷ (∃f∈F. ∃v∈keys p. f ≠ 0 ∧ lt f adds⇩t v)"
using is_red_addsE' is_red_addsI by auto
lemma is_red_subset:
assumes red: "is_red A p" and sub: "A ⊆ B"
shows "is_red B p"
proof -
from red obtain f v where "f ∈ A" and "v ∈ keys p" and "f ≠ 0" and "lt f adds⇩t v" by (rule is_red_addsE)
show ?thesis by (rule is_red_addsI, rule, fact+)
qed
lemma not_is_red_empty: "¬ is_red {} f"
by (simp add: is_red_adds_iff)
lemma red_single_mult_const:
assumes "red_single p q f t" and "c ≠ 0"
shows "red_single p q (monom_mult c 0 f) t"
proof -
let ?s = "t ⊕ lt f"
let ?f = "monom_mult c 0 f"
from assms(1) have "f ≠ 0" and "lookup p ?s ≠ 0"
and "q = p - monom_mult ((lookup p ?s) / lc f) t f" by (simp_all add: red_single_def)
from this(1) assms(2) have lt: "lt ?f = lt f" and lc: "lc ?f = c * lc f"
by (simp add: lt_monom_mult term_simps, simp)
show ?thesis unfolding red_single_def
proof (intro conjI)
from ‹f ≠ 0› assms(2) show "?f ≠ 0" by (simp add: monom_mult_eq_zero_iff)
next
from ‹lookup p ?s ≠ 0› show "lookup p (t ⊕ lt ?f) ≠ 0" by (simp add: lt)
next
show "q = p - monom_mult (lookup p (t ⊕ lt ?f) / lc ?f) t ?f"
by (simp add: lt monom_mult_assoc lc assms(2), fact)
qed
qed
lemma red_rtrancl_plus_higher:
assumes "(red F)⇧*⇧* p q" and "⋀u v. u ∈ keys p ⟹ v ∈ keys r ⟹ u ≺⇩t v"
shows "(red F)⇧*⇧* (p + r) (q + r)"
using assms(1)
proof induct
case base
show ?case ..
next
case (step y z)
from step(1) have "y ≼⇩p p" by (rule red_rtrancl_ord)
hence "lt y ≼⇩t lt p" by (rule ord_p_lt)
from step(2) have "red F (y + r) (z + r)"
proof (rule red_plus_keys_disjoint)
show "keys y ∩ keys r = {}"
proof (rule ccontr)
assume "keys y ∩ keys r ≠ {}"
then obtain v where "v ∈ keys y" and "v ∈ keys r" by auto
from this(1) have "v ≼⇩t lt y" and "y ≠ 0" using lt_max by (auto simp: in_keys_iff)
with ‹y ≼⇩p p› have "p ≠ 0" using ord_p_zero_min[of y] by auto
hence "lt p ∈ keys p" by (rule lt_in_keys)
from this ‹v ∈ keys r› have "lt p ≺⇩t v" by (rule assms(2))
with ‹lt y ≼⇩t lt p› have "lt y ≺⇩t v" by simp
with ‹v ≼⇩t lt y› show False by simp
qed
qed
with step(3) show ?case ..
qed
lemma red_mult_scalar_leading_monomial: "(red {f})⇧*⇧* (p ⊙ monomial (lc f) (lt f)) (- p ⊙ tail f)"
proof (cases "f = 0")
case True
show ?thesis by (simp add: True lc_def)
next
case False
show ?thesis
proof (induct p rule: punit.poly_mapping_tail_induct)
case 0
show ?case by simp
next
case (tail p)
from False have "lc f ≠ 0" by (rule lc_not_0)
from tail(1) have "punit.lc p ≠ 0" by (rule punit.lc_not_0)
let ?t = "punit.tail p ⊙ monomial (lc f) (lt f)"
let ?m = "monom_mult (punit.lc p) (punit.lt p) (monomial (lc f) (lt f))"
from ‹lc f ≠ 0› have kt: "keys ?t = (λt. t ⊕ lt f) ` keys (punit.tail p)"
by (rule keys_mult_scalar_monomial_right)
have km: "keys ?m = {punit.lt p ⊕ lt f}"
by (simp add: keys_monom_mult[OF ‹punit.lc p ≠ 0›] ‹lc f ≠ 0›)
from tail(2) have "(red {f})⇧*⇧* (?t + ?m) (- punit.tail p ⊙ tail f + ?m)"
proof (rule red_rtrancl_plus_higher)
fix u v
assume "u ∈ keys ?t" and "v ∈ keys ?m"
from this(1) obtain s where "s ∈ keys (punit.tail p)" and u: "u = s ⊕ lt f" unfolding kt ..
from this(1) have "punit.tail p ≠ 0" and "s ≼ punit.lt (punit.tail p)" using punit.lt_max by (auto simp: in_keys_iff)
moreover from ‹punit.tail p ≠ 0› have "punit.lt (punit.tail p) ≺ punit.lt p" by (rule punit.lt_tail)
ultimately have "s ≺ punit.lt p" by simp
moreover from ‹v ∈ keys ?m› have "v = punit.lt p ⊕ lt f" by (simp only: km, simp)
ultimately show "u ≺⇩t v" by (simp add: u splus_mono_strict_left)
qed
hence *: "(red {f})⇧*⇧* (p ⊙ monomial (lc f) (lt f)) (?m - punit.tail p ⊙ tail f)"
by (simp add: punit.leading_monomial_tail[symmetric, of p] mult_scalar_monomial[symmetric]
mult_scalar_distrib_right[symmetric] add.commute[of "punit.tail p"])
have "red {f} ?m (- (monomial (punit.lc p) (punit.lt p)) ⊙ tail f)" unfolding red_singleton
proof
show "red_single ?m (- (monomial (punit.lc p) (punit.lt p)) ⊙ tail f) f (punit.lt p)"
proof (simp add: red_single_def ‹f ≠ 0› km lookup_monom_mult ‹lc f ≠ 0› ‹punit.lc p ≠ 0› term_simps,
simp add: monom_mult_dist_right_minus[symmetric] mult_scalar_monomial)
have "monom_mult (punit.lc p) (punit.lt p) (monomial (lc f) (lt f) - f) =
- monom_mult (punit.lc p) (punit.lt p) (f - monomial (lc f) (lt f))"
by (metis minus_diff_eq monom_mult_uminus_right)
also have "... = - monom_mult (punit.lc p) (punit.lt p) (tail f)" by (simp only: tail_alt_2)
finally show "- monom_mult (punit.lc p) (punit.lt p) (tail f) =
monom_mult (punit.lc p) (punit.lt p) (monomial (lc f) (lt f) - f)" by simp
qed
qed
hence "red {f} (?m + (- punit.tail p ⊙ tail f))
(- (monomial (punit.lc p) (punit.lt p)) ⊙ tail f + (- punit.tail p ⊙ tail f))"
proof (rule red_plus_keys_disjoint)
show "keys ?m ∩ keys (- punit.tail p ⊙ tail f) = {}"
proof (cases "punit.tail p = 0")
case True
show ?thesis by (simp add: True)
next
case False
from tail(2) have "- punit.tail p ⊙ tail f ≼⇩p ?t" by (rule red_rtrancl_ord)
hence "lt (- punit.tail p ⊙ tail f) ≼⇩t lt ?t" by (rule ord_p_lt)
also from ‹lc f ≠ 0› False have "... = punit.lt (punit.tail p) ⊕ lt f"
by (rule lt_mult_scalar_monomial_right)
also from punit.lt_tail[OF False] have "... ≺⇩t punit.lt p ⊕ lt f" by (rule splus_mono_strict_left)
finally have "punit.lt p ⊕ lt f ∉ keys (- punit.tail p ⊙ tail f)" using lt_gr_keys by blast
thus ?thesis by (simp add: km)
qed
qed
hence "red {f} (?m - punit.tail p ⊙ tail f)
(- (monomial (punit.lc p) (punit.lt p)) ⊙ tail f - punit.tail p ⊙ tail f)"
by (simp add: term_simps)
also have "... = - p ⊙ tail f" using punit.leading_monomial_tail[symmetric, of p]
by (metis (mono_tags, lifting) add_uminus_conv_diff minus_add_distrib mult_scalar_distrib_right
mult_scalar_minus_mult_left)
finally have "red {f} (?m - punit.tail p ⊙ tail f) (- p ⊙ tail f)" .
with * show ?case ..
qed
qed
corollary red_mult_scalar_lt:
assumes "f ≠ 0"
shows "(red {f})⇧*⇧* (p ⊙ monomial c (lt f)) (monom_mult (- c / lc f) 0 (p ⊙ tail f))"
proof -
from assms have "lc f ≠ 0" by (rule lc_not_0)
hence 1: "p ⊙ monomial c (lt f) = punit.monom_mult (c / lc f) 0 p ⊙ monomial (lc f) (lt f)"
by (simp add: punit.mult_scalar_monomial[symmetric] mult.commute
mult_scalar_assoc mult_scalar_monomial_monomial term_simps)
have 2: "monom_mult (- c / lc f) 0 (p ⊙ tail f) = - punit.monom_mult (c / lc f) 0 p ⊙ tail f"
by (simp add: times_monomial_left[symmetric] mult_scalar_assoc
monom_mult_uminus_left mult_scalar_monomial)
show ?thesis unfolding 1 2 by (fact red_mult_scalar_leading_monomial)
qed
lemma is_red_monomial_iff: "is_red F (monomial c v) ⟷ (c ≠ 0 ∧ (∃f∈F. f ≠ 0 ∧ lt f adds⇩t v))"
by (simp add: is_red_adds_iff)
lemma is_red_monomialI:
assumes "c ≠ 0" and "f ∈ F" and "f ≠ 0" and "lt f adds⇩t v"
shows "is_red F (monomial c v)"
unfolding is_red_monomial_iff using assms by blast
lemma is_red_monomialD:
assumes "is_red F (monomial c v)"
shows "c ≠ 0"
using assms unfolding is_red_monomial_iff ..
lemma is_red_monomialE:
assumes "is_red F (monomial c v)"
obtains f where "f ∈ F" and "f ≠ 0" and "lt f adds⇩t v"
using assms unfolding is_red_monomial_iff by blast
lemma replace_lt_adds_stable_is_red:
assumes red: "is_red F f" and "q ≠ 0" and "lt q adds⇩t lt p"
shows "is_red (insert q (F - {p})) f"
proof -
from red obtain g v where "g ∈ F" and "g ≠ 0" and "v ∈ keys f" and "lt g adds⇩t v"
by (rule is_red_addsE)
show ?thesis
proof (cases "g = p")
case True
show ?thesis
proof (rule is_red_addsI)
show "q ∈ insert q (F - {p})" by simp
next
have "lt q adds⇩t lt p" by fact
also have "... adds⇩t v" using ‹lt g adds⇩t v› unfolding True .
finally show "lt q adds⇩t v" .
qed (fact+)
next
case False
with ‹g ∈ F› have "g ∈ insert q (F - {p})" by blast
from this ‹g ≠ 0› ‹v ∈ keys f› ‹lt g adds⇩t v› show ?thesis by (rule is_red_addsI)
qed
qed
lemma conversion_property:
assumes "is_red {p} f" and "red {r} p q"
shows "is_red {q} f ∨ is_red {r} f"
proof -
let ?s = "lp p - lp r"
from ‹is_red {p} f› obtain v where "v ∈ keys f" and "lt p adds⇩t v" and "p ≠ 0"
by (rule is_red_addsE, simp)
from red_indE[OF ‹red {r} p q›]
have "(r ≠ 0 ∧ lt r adds⇩t lt p ∧ q = p - monom_mult (lc p / lc r) ?s r) ∨
red {r} (tail p) (q - monomial (lc p) (lt p))" by simp
thus ?thesis
proof
assume "r ≠ 0 ∧ lt r adds⇩t lt p ∧ q = p - monom_mult (lc p / lc r) ?s r"
hence "r ≠ 0" and "lt r adds⇩t lt p" by simp_all
show ?thesis by (intro disjI2, rule is_red_singleton_trans, rule ‹is_red {p} f›, fact+)
next
assume "red {r} (tail p) (q - monomial (lc p) (lt p))" (is "red _ ?p' ?q'")
with red_ord have "?q' ≺⇩p ?p'" .
hence "?p' ≠ 0"
and assm: "(?q' = 0 ∨ ((lt ?q') ≺⇩t (lt ?p') ∨ (lt ?q') = (lt ?p')))"
unfolding ord_strict_p_rec[of ?q' ?p'] by (auto simp add: Let_def lc_def)
have "lt ?p' ≺⇩t lt p" by (rule lt_tail, fact)
let ?m = "monomial (lc p) (lt p)"
from monomial_0D[of "lt p" "lc p"] lc_not_0[OF ‹p ≠ 0›] have "?m ≠ 0" by blast
have "lt ?m = lt p" by (rule lt_monomial, rule lc_not_0, fact)
have "q ≠ 0 ∧ lt q = lt p"
proof (cases "?q' = 0")
case True
hence "q = ?m" by simp
with ‹?m ≠ 0› ‹lt ?m = lt p› show ?thesis by simp
next
case False
from assm show ?thesis
proof
assume "(lt ?q') ≺⇩t (lt ?p') ∨ (lt ?q') = (lt ?p')"
hence "lt ?q' ≼⇩t lt ?p'" by auto
also have "... ≺⇩t lt p" by fact
finally have "lt ?q' ≺⇩t lt p" .
hence "lt ?q' ≺⇩t lt ?m" unfolding ‹lt ?m = lt p› .
from lt_plus_eqI[OF this] ‹lt ?m = lt p› have "lt q = lt p" by simp
show ?thesis
proof (intro conjI, rule ccontr)
assume "¬ q ≠ 0"
hence "q = 0" by simp
hence "?q' = -?m" by simp
hence "lt ?q' = lt (-?m)" by simp
also have "... = lt ?m" using lt_uminus .
finally have "lt ?q' = lt ?m" .
with ‹lt ?q' ≺⇩t lt ?m› show False by simp
qed (fact)
next
assume "?q' = 0"
with False show ?thesis ..
qed
qed
hence "q ≠ 0" and "lt q adds⇩t lt p" by (simp_all add: term_simps)
show ?thesis by (intro disjI1, rule is_red_singleton_trans, rule ‹is_red {p} f›, fact+)
qed
qed
lemma replace_red_stable_is_red:
assumes a1: "is_red F f" and a2: "red (F - {p}) p q"
shows "is_red (insert q (F - {p})) f" (is "is_red ?F' f")
proof -
from a1 obtain g where "g ∈ F" and "is_red {g} f" by (rule is_red_singletonI)
show ?thesis
proof (cases "g = p")
case True
from a2 obtain h where "h ∈ F - {p}" and "red {h} p q" unfolding red_def by auto
from ‹is_red {g} f› have "is_red {p} f" unfolding True .
have "is_red {q} f ∨ is_red {h} f" by (rule conversion_property, fact+)
thus ?thesis
proof
assume "is_red {q} f"
show ?thesis
proof (rule is_red_singletonD)
show "q ∈ ?F'" by auto
qed fact
next
assume "is_red {h} f"
show ?thesis
proof (rule is_red_singletonD)
from ‹h ∈ F - {p}› show "h ∈ ?F'" by simp
qed fact
qed
next
case False
show ?thesis
proof (rule is_red_singletonD)
from ‹g ∈ F› False show "g ∈ ?F'" by blast
qed fact
qed
qed
lemma is_red_map_scale:
assumes "is_red F (c ⋅ p)"
shows "is_red F p"
proof -
from assms obtain f u where "f ∈ F" and "u ∈ keys (c ⋅ p)" and "f ≠ 0"
and a: "lt f adds⇩t u" by (rule is_red_addsE)
from this(2) keys_map_scale_subset have "u ∈ keys p" ..
with ‹f ∈ F› ‹f ≠ 0› show ?thesis using a by (rule is_red_addsI)
qed
corollary is_irred_map_scale: "¬ is_red F p ⟹ ¬ is_red F (c ⋅ p)"
by (auto dest: is_red_map_scale)
lemma is_red_map_scale_iff: "is_red F (c ⋅ p) ⟷ (c ≠ 0 ∧ is_red F p)"
proof (intro iffI conjI notI)
assume "is_red F (c ⋅ p)" and "c = 0"
thus False by (simp add: irred_0)
next
assume "is_red F (c ⋅ p)"
thus "is_red F p" by (rule is_red_map_scale)
next
assume "c ≠ 0 ∧ is_red F p"
hence "is_red F (inverse c ⋅ c ⋅ p)" by (simp add: map_scale_assoc)
thus "is_red F (c ⋅ p)" by (rule is_red_map_scale)
qed
lemma is_red_uminus: "is_red F (- p) ⟷ is_red F p"
by (auto elim!: is_red_addsE simp: keys_uminus intro: is_red_addsI)
lemma is_red_plus:
assumes "is_red F (p + q)"
shows "is_red F p ∨ is_red F q"
proof -
from assms obtain f u where "f ∈ F" and "u ∈ keys (p + q)" and "f ≠ 0"
and a: "lt f adds⇩t u" by (rule is_red_addsE)
from this(2) have "u ∈ keys p ∪ keys q"
by (meson Poly_Mapping.keys_add subsetD)
thus ?thesis
proof
assume "u ∈ keys p"
with ‹f ∈ F› ‹f ≠ 0› have "is_red F p" using a by (rule is_red_addsI)
thus ?thesis ..
next
assume "u ∈ keys q"
with ‹f ∈ F› ‹f ≠ 0› have "is_red F q" using a by (rule is_red_addsI)
thus ?thesis ..
qed
qed
lemma is_irred_plus: "¬ is_red F p ⟹ ¬ is_red F q ⟹ ¬ is_red F (p + q)"
by (auto dest: is_red_plus)
lemma is_red_minus:
assumes "is_red F (p - q)"
shows "is_red F p ∨ is_red F q"
proof -
from assms have "is_red F (p + (- q))" by simp
hence "is_red F p ∨ is_red F (- q)" by (rule is_red_plus)
thus ?thesis by (simp only: is_red_uminus)
qed
lemma is_irred_minus: "¬ is_red F p ⟹ ¬ is_red F q ⟹ ¬ is_red F (p - q)"
by (auto dest: is_red_minus)
end
subsection ‹Well-foundedness and Termination›
context gd_term
begin
lemma dgrad_set_le_red_single:
assumes "dickson_grading d" and "red_single p q f t"
shows "dgrad_set_le d {t} (pp_of_term ` keys p)"
proof (rule dgrad_set_leI, simp)
have "t adds t + lp f" by simp
with assms(1) have "d t ≤ d (pp_of_term (t ⊕ lt f))"
by (simp add: term_simps, rule dickson_grading_adds_imp_le)
moreover from assms(2) have "t ⊕ lt f ∈ keys p" by (simp add: in_keys_iff red_single_def)
ultimately show "∃v∈keys p. d t ≤ d (pp_of_term v)" ..
qed
lemma dgrad_p_set_le_red_single:
assumes "dickson_grading d" and "red_single p q f t"
shows "dgrad_p_set_le d {q} {f, p}"
proof -
let ?f = "monom_mult ((lookup p (t ⊕ lt f)) / lc f) t f"
from assms(2) have "t ⊕ lt f ∈ keys p" and q: "q = p - ?f" by (simp_all add: red_single_def in_keys_iff)
have "dgrad_p_set_le d {q} {p, ?f}" unfolding q by (fact dgrad_p_set_le_minus)
also have "dgrad_p_set_le d ... {f, p}"
proof (rule dgrad_p_set_leI_insert)
from assms(1) have "dgrad_set_le d (pp_of_term ` keys ?f) (insert t (pp_of_term ` keys f))"
by (rule dgrad_set_le_monom_mult)
also have "dgrad_set_le d ... (pp_of_term ` (keys f ∪ keys p))"
proof (rule dgrad_set_leI, simp)
fix s
assume "s = t ∨ s ∈ pp_of_term ` keys f"
thus "∃u∈keys f ∪ keys p. d s ≤ d (pp_of_term u)"
proof
assume "s = t"
from assms have "dgrad_set_le d {s} (pp_of_term ` keys p)" unfolding ‹s = t›
by (rule dgrad_set_le_red_single)
moreover have "s ∈ {s}" ..
ultimately obtain s0 where "s0 ∈ pp_of_term ` keys p" and "d s ≤ d s0" by (rule dgrad_set_leE)
from this(1) obtain u where "u ∈ keys p" and "s0 = pp_of_term u" ..
from this(1) have "u ∈ keys f ∪ keys p" by simp
with ‹d s ≤ d s0› show ?thesis unfolding ‹s0 = pp_of_term u› ..
next
assume "s ∈ pp_of_term ` keys f"
hence "s ∈ pp_of_term ` (keys f ∪ keys p)" by blast
then obtain u where "u ∈ keys f ∪ keys p" and "s = pp_of_term u" ..
note this(1)
moreover have "d s ≤ d s" ..
ultimately show ?thesis unfolding ‹s = pp_of_term u› ..
qed
qed
finally show "dgrad_p_set_le d {?f} {f, p}" by (simp add: dgrad_p_set_le_def Keys_insert)
next
show "dgrad_p_set_le d {p} {f, p}" by (rule dgrad_p_set_le_subset, simp)
qed
finally show ?thesis .
qed
lemma dgrad_p_set_le_red:
assumes "dickson_grading d" and "red F p q"
shows "dgrad_p_set_le d {q} (insert p F)"
proof -
from assms(2) obtain f t where "f ∈ F" and "red_single p q f t" by (rule red_setE)
from assms(1) this(2) have "dgrad_p_set_le d {q} {f, p}" by (rule dgrad_p_set_le_red_single)
also have "dgrad_p_set_le d ... (insert p F)" by (rule dgrad_p_set_le_subset, auto intro: ‹f ∈ F›)
finally show ?thesis .
qed
corollary dgrad_p_set_le_red_rtrancl:
assumes "dickson_grading d" and "(red F)⇧*⇧* p q"
shows "dgrad_p_set_le d {q} (insert p F)"
using assms(2)
proof (induct)
case base
show ?case by (rule dgrad_p_set_le_subset, simp)
next
case (step y z)
from assms(1) step(2) have "dgrad_p_set_le d {z} (insert y F)" by (rule dgrad_p_set_le_red)
also have "dgrad_p_set_le d ... (insert p F)"
proof (rule dgrad_p_set_leI_insert)
show "dgrad_p_set_le d F (insert p F)" by (rule dgrad_p_set_le_subset, blast)
qed fact
finally show ?case .
qed
lemma dgrad_p_set_red_single_pp:
assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "red_single p q f t"
shows "d t ≤ m"
proof -
from assms(1) assms(3) have "dgrad_set_le d {t} (pp_of_term ` keys p)" by (rule dgrad_set_le_red_single)
moreover have "t ∈ {t}" ..
ultimately obtain s where "s ∈ pp_of_term ` keys p" and "d t ≤ d s" by (rule dgrad_set_leE)
from this(1) obtain u where "u ∈ keys p" and "s = pp_of_term u" ..
from assms(2) this(1) have "d (pp_of_term u) ≤ m" by (rule dgrad_p_setD)
with ‹d t ≤ d s› show ?thesis unfolding ‹s = pp_of_term u› by (rule le_trans)
qed
lemma dgrad_p_set_closed_red_single:
assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "f ∈ dgrad_p_set d m"
and "red_single p q f t"
shows "q ∈ dgrad_p_set d m"
proof -
from dgrad_p_set_le_red_single[OF assms(1, 4)] have "{q} ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
from assms(2, 3) show "{f, p} ⊆ dgrad_p_set d m" by simp
qed
thus ?thesis by simp
qed
lemma dgrad_p_set_closed_red:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m" and "red F p q"
shows "q ∈ dgrad_p_set d m"
proof -
from assms(4) obtain f t where "f ∈ F" and *: "red_single p q f t" by (rule red_setE)
from assms(2) this(1) have "f ∈ dgrad_p_set d m" ..
from assms(1) assms(3) this * show ?thesis by (rule dgrad_p_set_closed_red_single)
qed
lemma dgrad_p_set_closed_red_rtrancl:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m" and "(red F)⇧*⇧* p q"
shows "q ∈ dgrad_p_set d m"
using assms(4)
proof (induct)
case base
from assms(3) show ?case .
next
case (step r q)
from assms(1) assms(2) step(3) step(2) show "q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red)
qed
lemma red_rtrancl_repE:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" and "finite G" and "p ∈ dgrad_p_set d m"
and "(red G)⇧*⇧* p r"
obtains q where "p = r + (∑g∈G. q g ⊙ g)" and "⋀g. q g ∈ punit.dgrad_p_set d m"
and "⋀g. lt (q g ⊙ g) ≼⇩t lt p"
using assms(5)
proof (induct r arbitrary: thesis)
case base
show ?case
proof (rule base)
show "p = p + (∑g∈G. 0 ⊙ g)" by simp
qed (simp_all add: punit.zero_in_dgrad_p_set min_term_min)
next
case (step r' r)
from step.hyps(2) obtain g t where "g ∈ G" and rs: "red_single r' r g t" by (rule red_setE)
from this(2) have "r' = r + monomial (lookup r' (t ⊕ lt g) / lc g) t ⊙ g"
by (simp add: red_single_def mult_scalar_monomial)
moreover define q0 where "q0 = monomial (lookup r' (t ⊕ lt g) / lc g) t"
ultimately have r': "r' = r + q0 ⊙ g" by simp
obtain q' where p: "p = r' + (∑g∈G. q' g ⊙ g)" and 1: "⋀g. q' g ∈ punit.dgrad_p_set d m"
and 2: "⋀g. lt (q' g ⊙ g) ≼⇩t lt p" by (rule step.hyps) blast
define q where "q = q'(g := q0 + q' g)"
show ?case
proof (rule step.prems)
from assms(3) ‹g ∈ G› have "p = (r + q0 ⊙ g) + (q' g ⊙ g + (∑g∈G - {g}. q' g ⊙ g))"
by (simp add: p r' sum.remove)
also have "… = r + (q g ⊙ g + (∑g∈G - {g}. q' g ⊙ g))"
by (simp add: q_def mult_scalar_distrib_right)
also from refl have "(∑g∈G - {g}. q' g ⊙ g) = (∑g∈G - {g}. q g ⊙ g)"
by (rule sum.cong) (simp add: q_def)
finally show "p = r + (∑g∈G. q g ⊙ g)" using assms(3) ‹g ∈ G› by (simp only: sum.remove)
next
fix g0
have "q g0 ∈ punit.dgrad_p_set d m ∧ lt (q g0 ⊙ g0) ≼⇩t lt p"
proof (cases "g0 = g")
case True
have eq: "q g = q0 + q' g" by (simp add: q_def)
show ?thesis unfolding True eq
proof
from assms(1, 2, 4) step.hyps(1) have "r' ∈ dgrad_p_set d m"
by (rule dgrad_p_set_closed_red_rtrancl)
with assms(1) have "d t ≤ m" using rs by (rule dgrad_p_set_red_single_pp)
hence "q0 ∈ punit.dgrad_p_set d m" by (simp add: q0_def punit.dgrad_p_set_def dgrad_set_def)
thus "q0 + q' g ∈ punit.dgrad_p_set d m" by (intro punit.dgrad_p_set_closed_plus 1)
next
have "lt (q0 ⊙ g + q' g ⊙ g) ≼⇩t ord_term_lin.max (lt (q0 ⊙ g)) (lt (q' g ⊙ g))"
by (fact lt_plus_le_max)
also have "… ≼⇩t lt p"
proof (intro ord_term_lin.max.boundedI 2)
have "lt (q0 ⊙ g) ≼⇩t t ⊕ lt g" by (simp add: q0_def mult_scalar_monomial lt_monom_mult_le)
also from rs have "… ≼⇩t lt r'" by (intro lt_max) (simp add: red_single_def)
also from step.hyps(1) have "… ≼⇩t lt p" by (intro ord_p_lt red_rtrancl_ord)
finally show "lt (q0 ⊙ g) ≼⇩t lt p" .
qed
finally show "lt ((q0 + q' g) ⊙ g) ≼⇩t lt p" by (simp only: mult_scalar_distrib_right)
qed
next
case False
hence "q g0 = q' g0" by (simp add: q_def)
thus ?thesis by (simp add: 1 2)
qed
thus "q g0 ∈ punit.dgrad_p_set d m" and "lt (q g0 ⊙ g0) ≼⇩t lt p" by simp_all
qed
qed
lemma is_relation_order_red:
assumes "dickson_grading d"
shows "Confluence.relation_order (red F) (≺⇩p) (dgrad_p_set d m)"
proof
show "wfp_on (≺⇩p) (dgrad_p_set d m)"
proof (rule wfp_onI_min)
fix x::"'t ⇒⇩0 'c" and Q
assume "x ∈ Q" and "Q ⊆ dgrad_p_set d m"
with assms obtain q where "q ∈ Q" and *: "⋀y. y ≺⇩p q ⟹ y ∉ Q"
by (rule ord_p_minimum_dgrad_p_set, auto)
from this(1) show "∃z∈Q. ∀y∈dgrad_p_set d m. y ≺⇩p z ⟶ y ∉ Q"
proof
from * show "∀y∈dgrad_p_set d m. y ≺⇩p q ⟶ y ∉ Q" by auto
qed
qed
next
show "red F ≤ (≺⇩p)¯¯" by (simp add: predicate2I red_ord)
qed (fact ord_strict_p_transitive)
lemma red_wf_dgrad_p_set_aux:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m"
shows "wfp_on (red F)¯¯ (dgrad_p_set d m)"
proof (rule wfp_onI_min)
fix x::"'t ⇒⇩0 'b" and Q
assume "x ∈ Q" and "Q ⊆ dgrad_p_set d m"
with assms(1) obtain q where "q ∈ Q" and *: "⋀y. y ≺⇩p q ⟹ y ∉ Q"
by (rule ord_p_minimum_dgrad_p_set, auto)
from this(1) show "∃z∈Q. ∀y∈dgrad_p_set d m. (red F)¯¯ y z ⟶ y ∉ Q"
proof
show "∀y∈dgrad_p_set d m. (red F)¯¯ y q ⟶ y ∉ Q"
proof (intro ballI impI, simp)
fix y
assume "red F q y"
hence "y ≺⇩p q" by (rule red_ord)
thus "y ∉ Q" by (rule *)
qed
qed
qed
lemma red_wf_dgrad_p_set:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m"
shows "wfP (red F)¯¯"
proof (rule wfI_min[to_pred])
fix x::"'t ⇒⇩0 'b" and Q
assume "x ∈ Q"
from assms(2) obtain n where "m ≤ n" and "x ∈ dgrad_p_set d n" and "F ⊆ dgrad_p_set d n"
by (rule dgrad_p_set_insert)
let ?Q = "Q ∩ dgrad_p_set d n"
from assms(1) ‹F ⊆ dgrad_p_set d n› have "wfp_on (red F)¯¯ (dgrad_p_set d n)"
by (rule red_wf_dgrad_p_set_aux)
moreover from ‹x ∈ Q› ‹x ∈ dgrad_p_set d n› have "x ∈ ?Q" ..
moreover have "?Q ⊆ dgrad_p_set d n" by simp
ultimately obtain z where "z ∈ ?Q" and *: "⋀y. (red F)¯¯ y z ⟹ y ∉ ?Q" by (rule wfp_onE_min) blast
from this(1) have "z ∈ Q" and "z ∈ dgrad_p_set d n" by simp_all
from this(1) show "∃z∈Q. ∀y. (red F)¯¯ y z ⟶ y ∉ Q"
proof
show "∀y. (red F)¯¯ y z ⟶ y ∉ Q"
proof (intro allI impI)
fix y
assume "(red F)¯¯ y z"
hence "red F z y" by simp
with assms(1) ‹F ⊆ dgrad_p_set d n› ‹z ∈ dgrad_p_set d n› have "y ∈ dgrad_p_set d n"
by (rule dgrad_p_set_closed_red)
moreover from ‹(red F)¯¯ y z› have "y ∉ ?Q" by (rule *)
ultimately show "y ∉ Q" by blast
qed
qed
qed
lemmas red_wf_finite = red_wf_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemma cbelow_on_monom_mult:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "d t ≤ m" and "c ≠ 0"
and "cbelow_on (dgrad_p_set d m) (≺⇩p) z (λa b. red F a b ∨ red F b a) p q"
shows "cbelow_on (dgrad_p_set d m) (≺⇩p) (monom_mult c t z) (λa b. red F a b ∨ red F b a)
(monom_mult c t p) (monom_mult c t q)"
using assms(5)
proof (induct rule: cbelow_on_induct)
case base
show ?case unfolding cbelow_on_def
proof (rule disjI1, intro conjI, fact refl)
from assms(5) have "p ∈ dgrad_p_set d m" by (rule cbelow_on_first_in)
with assms(1) assms(3) show "monom_mult c t p ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_monom_mult)
next
from assms(5) have "p ≺⇩p z" by (rule cbelow_on_first_below)
from this assms(4) show "monom_mult c t p ≺⇩p monom_mult c t z" by (rule ord_strict_p_monom_mult)
qed
next
case (step q' q)
let ?R = "λa b. red F a b ∨ red F b a"
from step(5) show ?case
proof
from assms(1) assms(3) step(3) show "monom_mult c t q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_monom_mult)
next
from step(2) red_monom_mult[OF _ assms(4)] show "?R (monom_mult c t q') (monom_mult c t q)" by auto
next
from step(4) assms(4) show "monom_mult c t q ≺⇩p monom_mult c t z" by (rule ord_strict_p_monom_mult)
qed
qed
lemma cbelow_on_monom_mult_monomial:
assumes "c ≠ 0"
and "cbelow_on (dgrad_p_set d m) (≺⇩p) (monomial c' v) (λa b. red F a b ∨ red F b a) p q"
shows "cbelow_on (dgrad_p_set d m) (≺⇩p) (monomial c (t ⊕ v)) (λa b. red F a b ∨ red F b a) p q"
proof -
have *: "f ≺⇩p monomial c' v ⟹ f ≺⇩p monomial c (t ⊕ v)" for f
proof (simp add: ord_strict_p_monomial_iff assms(1), elim conjE disjE, erule disjI1, rule disjI2)
assume "lt f ≺⇩t v"
also have "... ≼⇩t t ⊕ v" using local.zero_min using splus_mono_left splus_zero by fastforce
finally show "lt f ≺⇩t t ⊕ v" .
qed
from assms(2) show ?thesis
proof (induct rule: cbelow_on_induct)
case base
show ?case unfolding cbelow_on_def
proof (rule disjI1, intro conjI, fact refl)
from assms(2) show "p ∈ dgrad_p_set d m" by (rule cbelow_on_first_in)
next
from assms(2) have "p ≺⇩p monomial c' v" by (rule cbelow_on_first_below)
thus "p ≺⇩p monomial c (t ⊕ v)" by (rule *)
qed
next
case (step q' q)
let ?R = "λa b. red F a b ∨ red F b a"
from step(5) step(3) step(2) show ?case
proof
from step(4) show "q ≺⇩p monomial c (t ⊕ v)" by (rule *)
qed
qed
qed
lemma cbelow_on_plus:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "r ∈ dgrad_p_set d m"
and "keys r ∩ keys z = {}"
and "cbelow_on (dgrad_p_set d m) (≺⇩p) z (λa b. red F a b ∨ red F b a) p q"
shows "cbelow_on (dgrad_p_set d m) (≺⇩p) (z + r) (λa b. red F a b ∨ red F b a) (p + r) (q + r)"
using assms(5)
proof (induct rule: cbelow_on_induct)
case base
show ?case unfolding cbelow_on_def
proof (rule disjI1, intro conjI, fact refl)
from assms(5) have "p ∈ dgrad_p_set d m" by (rule cbelow_on_first_in)
from this assms(3) show "p + r ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_plus)
next
from assms(5) have "p ≺⇩p z" by (rule cbelow_on_first_below)
from this assms(4) show "p + r ≺⇩p z + r" by (rule ord_strict_p_plus)
qed
next
case (step q' q)
let ?RS = "λa b. red F a b ∨ red F b a"
let ?A = "dgrad_p_set d m"
let ?R = "red F"
let ?ord = "(≺⇩p)"
from assms(1) have ro: "relation_order ?R ?ord ?A"
by (rule is_relation_order_red)
have dw: "relation.dw_closed ?R ?A"
by (rule relation.dw_closedI, rule dgrad_p_set_closed_red, rule assms(1), rule assms(2))
from step(2) have "relation.cs (red F) (q' + r) (q + r)"
proof
assume "red F q q'"
hence "relation.cs (red F) (q + r) (q' + r)" by (rule red_plus_cs)
thus ?thesis by (rule relation.cs_sym)
next
assume "red F q' q"
thus ?thesis by (rule red_plus_cs)
qed
with ro dw have "cbelow_on ?A ?ord (z + r) ?RS (q' + r) (q + r)"
proof (rule relation_order.cs_implies_cbelow_on)
from step(1) have "q' ∈ ?A" by (rule cbelow_on_second_in)
from this assms(3) show "q' + r ∈ ?A" by (rule dgrad_p_set_closed_plus)
next
from step(3) assms(3) show "q + r ∈ ?A" by (rule dgrad_p_set_closed_plus)
next
from step(1) have "q' ≺⇩p z" by (rule cbelow_on_second_below)
from this assms(4) show "q' + r ≺⇩p z + r" by (rule ord_strict_p_plus)
next
from step(4) assms(4) show "q + r ≺⇩p z + r" by (rule ord_strict_p_plus)
qed
with step(5) show ?case by (rule cbelow_on_transitive)
qed
lemma is_full_pmdlI_lt_dgrad_p_set:
assumes "dickson_grading d" and "B ⊆ dgrad_p_set d m"
assumes "⋀k. k ∈ component_of_term ` Keys (B::('t ⇒⇩0 'b::field) set) ⟹
(∃b∈B. b ≠ 0 ∧ component_of_term (lt b) = k ∧ lp b = 0)"
shows "is_full_pmdl B"
proof (rule is_full_pmdlI)
fix p::"'t ⇒⇩0 'b"
from assms(1, 2) have "wfP (red B)¯¯" by (rule red_wf_dgrad_p_set)
moreover assume "component_of_term ` keys p ⊆ component_of_term ` Keys B"
ultimately show "p ∈ pmdl B"
proof (induct p)
case (less p)
show ?case
proof (cases "p = 0")
case True
show ?thesis by (simp add: True pmdl.span_zero)
next
case False
hence "lt p ∈ keys p" by (rule lt_in_keys)
hence "component_of_term (lt p) ∈ component_of_term ` keys p" by simp
also have "... ⊆ component_of_term ` Keys B" by fact
finally have "∃b∈B. b ≠ 0 ∧ component_of_term (lt b) = component_of_term (lt p) ∧ lp b = 0"
by (rule assms(3))
then obtain b where "b ∈ B" and "b ≠ 0" and "component_of_term (lt b) = component_of_term (lt p)"
and "lp b = 0" by blast
from this(3, 4) have eq: "lp p ⊕ lt b = lt p" by (simp add: splus_def term_of_pair_pair)
define q where "q = p - monom_mult (lookup p ((lp p) ⊕ lt b) / lc b) (lp p) b"
have "red_single p q b (lp p)"
by (auto simp: red_single_def ‹b ≠ 0› q_def eq ‹lt p ∈ keys p›)
with ‹b ∈ B› have "red B p q" by (rule red_setI)
hence "(red B)¯¯ q p" ..
moreover have "component_of_term ` keys q ⊆ component_of_term ` Keys B"
proof (rule subset_trans)
from ‹red B p q› show "component_of_term ` keys q ⊆ component_of_term ` keys p ∪ component_of_term ` Keys B"
by (rule components_red_subset)
next
from less(2) show "component_of_term ` keys p ∪ component_of_term ` Keys B ⊆ component_of_term ` Keys B"
by blast
qed
ultimately have "q ∈ pmdl B" by (rule less.hyps)
have "q + monom_mult (lookup p ((lp p) ⊕ lt b) / lc b) (lp p) b ∈ pmdl B"
by (rule pmdl.span_add, fact, rule pmdl_closed_monom_mult, rule pmdl.span_base, fact)
thus ?thesis by (simp add: q_def)
qed
qed
qed
lemmas is_full_pmdlI_lt_finite = is_full_pmdlI_lt_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
end
subsection ‹Algorithms›
subsubsection ‹Function ‹find_adds››
context ordered_term
begin
primrec find_adds :: "('t ⇒⇩0 'b) list ⇒ 't ⇒ ('t ⇒⇩0 'b::zero) option" where
"find_adds [] _ = None"|
"find_adds (f # fs) u = (if f ≠ 0 ∧ lt f adds⇩t u then Some f else find_adds fs u)"
lemma find_adds_SomeD1:
assumes "find_adds fs u = Some f"
shows "f ∈ set fs"
using assms by (induct fs, simp, simp split: if_splits)
lemma find_adds_SomeD2:
assumes "find_adds fs u = Some f"
shows "f ≠ 0"
using assms by (induct fs, simp, simp split: if_splits)
lemma find_adds_SomeD3:
assumes "find_adds fs u = Some f"
shows "lt f adds⇩t u"
using assms by (induct fs, simp, simp split: if_splits)
lemma find_adds_NoneE:
assumes "find_adds fs u = None" and "f ∈ set fs"
assumes "f = 0 ⟹ thesis" and "f ≠ 0 ⟹ ¬ lt f adds⇩t u ⟹ thesis"
shows thesis
using assms
proof (induct fs arbitrary: thesis)
case Nil
from Nil(2) show ?case by simp
next
case (Cons a fs)
from Cons(2) have 1: "a = 0 ∨ ¬ lt a adds⇩t u" and 2: "find_adds fs u = None"
by (simp_all split: if_splits)
from Cons(3) have "f = a ∨ f ∈ set fs" by simp
thus ?case
proof
assume "f = a"
show ?thesis
proof (cases "a = 0")
case True
show ?thesis by (rule Cons(4), simp add: ‹f = a› True)
next
case False
with 1 have *: "¬ lt a adds⇩t u" by simp
show ?thesis by (rule Cons(5), simp_all add: ‹f = a› * False)
qed
next
assume "f ∈ set fs"
with 2 show ?thesis
proof (rule Cons(1))
assume "f = 0"
thus ?thesis by (rule Cons(4))
next
assume "f ≠ 0" and "¬ lt f adds⇩t u"
thus ?thesis by (rule Cons(5))
qed
qed
qed
lemma find_adds_SomeD_red_single:
assumes "p ≠ 0" and "find_adds fs (lt p) = Some f"
shows "red_single p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) f (lp p - lp f)"
proof -
let ?f = "monom_mult (lc p / lc f) (lp p - lp f) f"
from assms(2) have "f ≠ 0" and "lt f adds⇩t lt p" by (rule find_adds_SomeD2, rule find_adds_SomeD3)
from this(2) have eq: "(lp p - lp f) ⊕ lt f = lt p"
by (simp add: adds_minus_splus adds_term_def term_of_pair_pair)
from assms(1) have "lc p ≠ 0" by (rule lc_not_0)
moreover from ‹f ≠ 0› have "lc f ≠ 0" by (rule lc_not_0)
ultimately have "lc p / lc f ≠ 0" by simp
hence "lt ?f = (lp p - lp f) ⊕ lt f" by (simp add: lt_monom_mult ‹f ≠ 0›)
hence lt_f: "lt ?f = lt p" by (simp only: eq)
have "lookup ?f (lt p) = lookup ?f ((lp p - lp f) ⊕ lt f)" by (simp only: eq)
also have "... = (lc p / lc f) * lookup f (lt f)" by (rule lookup_monom_mult_plus)
also from ‹lc f ≠ 0› have "... = lookup p (lt p)" by (simp add: lc_def)
finally have lc_f: "lookup ?f (lt p) = lookup p (lt p)" .
have "red_single p (p - ?f) f (lp p - lp f)"
by (auto simp: red_single_def eq lc_def ‹f ≠ 0› lt_in_keys assms(1))
moreover have "p - ?f = tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)"
by (rule poly_mapping_eqI,
simp add: tail_monom_mult[symmetric] lookup_minus lookup_tail_2 lt_f lc_f split: if_split)
ultimately show ?thesis by simp
qed
lemma find_adds_SomeD_red:
assumes "p ≠ 0" and "find_adds fs (lt p) = Some f"
shows "red (set fs) p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f))"
proof (rule red_setI)
from assms(2) show "f ∈ set fs" by (rule find_adds_SomeD1)
next
from assms show "red_single p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) f (lp p - lp f)"
by (rule find_adds_SomeD_red_single)
qed
end
subsubsection ‹Function ‹trd››
context gd_term
begin
definition trd_term :: "('a ⇒ nat) ⇒ ((('t ⇒⇩0 'b::field) list × ('t ⇒⇩0 'b) × ('t ⇒⇩0 'b)) ×
(('t ⇒⇩0 'b) list × ('t ⇒⇩0 'b) × ('t ⇒⇩0 'b))) set"
where "trd_term d = {(x, y). dgrad_p_set_le d (set (fst (snd x) # fst x)) (set (fst (snd y) # fst y)) ∧ fst (snd x) ≺⇩p fst (snd y)}"
lemma trd_term_wf:
assumes "dickson_grading d"
shows "wf (trd_term d)"
proof (rule wfI_min)
fix x :: "('t ⇒⇩0 'b::field) list × ('t ⇒⇩0 'b) × ('t ⇒⇩0 'b)" and Q
assume "x ∈ Q"
let ?A = "set (fst (snd x) # fst x)"
have "finite ?A" ..
then obtain m where A: "?A ⊆ dgrad_p_set d m" by (rule dgrad_p_set_exhaust)
let ?B = "dgrad_p_set d m"
let ?Q = "{q ∈ Q. set (fst (snd q) # fst q) ⊆ ?B}"
note assms
moreover have "fst (snd x) ∈ fst ` snd ` ?Q"
by (rule, fact refl, rule, fact refl, simp only: mem_Collect_eq A ‹x ∈ Q›)
moreover have "fst ` snd ` ?Q ⊆ ?B" by auto
ultimately obtain z0 where "z0 ∈ fst ` snd ` ?Q"
and *: "⋀y. y ≺⇩p z0 ⟹ y ∉ fst ` snd ` ?Q" by (rule ord_p_minimum_dgrad_p_set, blast)
from this(1) obtain z where "z ∈ {q ∈ Q. set (fst (snd q) # fst q) ⊆ ?B}" and z0: "z0 = fst (snd z)"
by fastforce
from this(1) have "z ∈ Q" and a: "set (fst (snd z) # fst z) ⊆ ?B" by simp_all
from this(1) show "∃z∈Q. ∀y. (y, z) ∈ trd_term d ⟶ y ∉ Q"
proof
show "∀y. (y, z) ∈ trd_term d ⟶ y ∉ Q"
proof (intro allI impI)
fix y
assume "(y, z) ∈ trd_term d"
hence b: "dgrad_p_set_le d (set (fst (snd y) # fst y)) (set (fst (snd z) # fst z))" and "fst (snd y) ≺⇩p z0"
by (simp_all add: trd_term_def z0)
from this(2) have "fst (snd y) ∉ fst ` snd ` ?Q" by (rule *)
hence "y ∉ Q ∨ ¬ set (fst (snd y) # fst y) ⊆ ?B" by auto
moreover from b a have "set (fst (snd y) # fst y) ⊆ ?B" by (rule dgrad_p_set_le_dgrad_p_set)
ultimately show "y ∉ Q" by simp
qed
qed
qed
function trd_aux :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::field)" where
"trd_aux fs p r =
(if p = 0 then
r
else
case find_adds fs (lt p) of
None ⇒ trd_aux fs (tail p) (r + monomial (lc p) (lt p))
| Some f ⇒ trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r
)"
by auto
termination proof -
from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" ..
let ?R = "trd_term d"
show ?thesis
proof (rule, rule trd_term_wf, fact)
fix fs and p r::"'t ⇒⇩0 'b"
assume "p ≠ 0"
show "((fs, tail p, r + monomial (lc p) (lt p)), fs, p, r) ∈ trd_term d"
proof (simp add: trd_term_def, rule)
show "dgrad_p_set_le d (insert (tail p) (set fs)) (insert p (set fs))"
proof (rule dgrad_p_set_leI_insert_keys, rule dgrad_p_set_le_subset, rule subset_insertI,
rule dgrad_set_le_subset, simp add: Keys_insert image_Un)
have "keys (tail p) ⊆ keys p" by (auto simp: keys_tail)
hence "pp_of_term ` keys (tail p) ⊆ pp_of_term ` keys p" by (rule image_mono)
thus "pp_of_term ` keys (tail p) ⊆ pp_of_term ` keys p ∪ pp_of_term ` Keys (set fs)" by blast
qed
next
from ‹p ≠ 0› show "tail p ≺⇩p p" by (rule tail_ord_p)
qed
next
fix fs::"('t ⇒⇩0 'b) list" and p r f ::"'t ⇒⇩0 'b"
assume "p ≠ 0" and "find_adds fs (lt p) = Some f"
hence "red (set fs) p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f))"
(is "red _ p ?q") by (rule find_adds_SomeD_red)
show "((fs, ?q, r), fs, p, r) ∈ trd_term d"
by (simp add: trd_term_def, rule, rule dgrad_p_set_leI_insert, rule dgrad_p_set_le_subset, rule subset_insertI,
rule dgrad_p_set_le_red, fact dg, fact ‹red (set fs) p ?q›, rule red_ord, fact)
qed
qed
definition trd :: "('t ⇒⇩0 'b::field) list ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b)"
where "trd fs p = trd_aux fs p 0"
lemma trd_aux_red_rtrancl: "(red (set fs))⇧*⇧* p (trd_aux fs p r - r)"
proof (induct fs p r rule: trd_aux.induct)
case (1 fs p r)
show ?case
proof (simp, split option.split, intro conjI impI allI)
assume "p ≠ 0" and "find_adds fs (lt p) = None"
hence "(red (set fs))⇧*⇧* (tail p) (trd_aux fs (tail p) (r + monomial (lc p) (lt p)) - (r + monomial (lc p) (lt p)))"
by (rule 1(1))
hence "(red (set fs))⇧*⇧* (tail p + monomial (lc p) (lt p))
(trd_aux fs (tail p) (r + monomial (lc p) (lt p)) - (r + monomial (lc p) (lt p)) + monomial (lc p ) (lt p))"
proof (rule red_rtrancl_plus_higher)
fix u v
assume "u ∈ keys (tail p)"
assume "v ∈ keys (monomial (lc p) (lt p))"
also have "... ⊆ {lt p}" by (simp add: keys_monomial)
finally have "v = lt p" by simp
from ‹u ∈ keys (tail p)› show "u ≺⇩t v" unfolding ‹v = lt p› by (rule keys_tail_less_lt)
qed
thus "(red (set fs))⇧*⇧* p (trd_aux fs (tail p) (r + monomial (lc p) (lt p)) - r)"
by (simp only: leading_monomial_tail[symmetric] add.commute[of _ "monomial (lc p) (lt p)"], simp)
next
fix f
assume "p ≠ 0" and "find_adds fs (lt p) = Some f"
hence "(red (set fs))⇧*⇧* (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f))
(trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r - r)"
and *: "red (set fs) p (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f))"
by (rule 1(2), rule find_adds_SomeD_red)
let ?q = "tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)"
from * have "(red (set fs))⇧*⇧* p ?q" ..
moreover have "(red (set fs))⇧*⇧* ?q (trd_aux fs ?q r - r)" by fact
ultimately show "(red (set fs))⇧*⇧* p (trd_aux fs ?q r - r)" by (rule rtranclp_trans)
qed
qed
corollary trd_red_rtrancl: "(red (set fs))⇧*⇧* p (trd fs p)"
proof -
have "(red (set fs))⇧*⇧* p (trd fs p - 0)" unfolding trd_def by (rule trd_aux_red_rtrancl)
thus ?thesis by simp
qed
lemma trd_aux_irred:
assumes "¬ is_red (set fs) r"
shows "¬ is_red (set fs) (trd_aux fs p r)"
using assms
proof (induct fs p r rule: trd_aux.induct)
case (1 fs p r)
show ?case
proof (simp add: 1(3), split option.split, intro impI conjI allI)
assume "p ≠ 0" and *: "find_adds fs (lt p) = None"
thus "¬ is_red (set fs) (trd_aux fs (tail p) (r + monomial (lc p) (lt p)))"
proof (rule 1(1))
show "¬ is_red (set fs) (r + monomial (lc p) (lt p))"
proof
assume "is_red (set fs) (r + monomial (lc p) (lt p))"
then obtain f u where "f ∈ set fs" and "f ≠ 0" and "u ∈ keys (r + monomial (lc p) (lt p))"
and "lt f adds⇩t u" by (rule is_red_addsE)
note this(3)
also have "keys (r + monomial (lc p) (lt p)) ⊆ keys r ∪ keys (monomial (lc p) (lt p))"
by (rule Poly_Mapping.keys_add)
also have "... ⊆ insert (lt p) (keys r)" by auto
finally show False
proof
assume "u = lt p"
from * ‹f ∈ set fs› show ?thesis
proof (rule find_adds_NoneE)
assume "f = 0"
with ‹f ≠ 0› show ?thesis ..
next
assume "¬ lt f adds⇩t lt p"
from this ‹lt f adds⇩t u› show ?thesis unfolding ‹u = lt p› ..
qed
next
assume "u ∈ keys r"
from ‹f ∈ set fs› ‹f ≠ 0› this ‹lt f adds⇩t u› have "is_red (set fs) r" by (rule is_red_addsI)
with 1(3) show ?thesis ..
qed
qed
qed
next
fix f
assume "p ≠ 0" and "find_adds fs (lt p) = Some f"
from this 1(3) show "¬ is_red (set fs) (trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r)"
by (rule 1(2))
qed
qed
corollary trd_irred: "¬ is_red (set fs) (trd fs p)"
unfolding trd_def using irred_0 by (rule trd_aux_irred)
lemma trd_in_pmdl: "p - (trd fs p) ∈ pmdl (set fs)"
using trd_red_rtrancl by (rule red_rtranclp_diff_in_pmdl)
lemma pmdl_closed_trd:
assumes "p ∈ pmdl B" and "set fs ⊆ pmdl B"
shows "(trd fs p) ∈ pmdl B"
proof -
from assms(2) have "pmdl (set fs) ⊆ pmdl B" by (rule pmdl.span_subset_spanI)
with trd_in_pmdl have "p - trd fs p ∈ pmdl B" ..
with assms(1) have "p - (p - trd fs p) ∈ pmdl B" by (rule pmdl.span_diff)
thus ?thesis by simp
qed
end
end
Theory Groebner_Bases
section ‹Gr\"obner Bases and Buchberger's Theorem›
theory Groebner_Bases
imports Reduction
begin
text ‹This theory provides the main results about Gr\"obner bases for modules of multivariate polynomials.›
context gd_term
begin
definition crit_pair :: "('t ⇒⇩0 'b::field) ⇒ ('t ⇒⇩0 'b) ⇒ (('t ⇒⇩0 'b) × ('t ⇒⇩0 'b))"
where "crit_pair p q =
(if component_of_term (lt p) = component_of_term (lt q) then
(monom_mult (1 / lc p) ((lcs (lp p) (lp q)) - (lp p)) (tail p),
monom_mult (1 / lc q) ((lcs (lp p) (lp q)) - (lp q)) (tail q))
else (0, 0))"
definition crit_pair_cbelow_on :: "('a ⇒ nat) ⇒ nat ⇒ ('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ bool"
where "crit_pair_cbelow_on d m F p q ⟷
cbelow_on (dgrad_p_set d m) (≺⇩p)
(monomial 1 (term_of_pair (lcs (lp p) (lp q), component_of_term (lt p))))
(λa b. red F a b ∨ red F b a) (fst (crit_pair p q)) (snd (crit_pair p q))"
definition spoly :: "('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::field)"
where "spoly p q = (let v1 = lt p; v2 = lt q in
if component_of_term v1 = component_of_term v2 then
let t1 = pp_of_term v1; t2 = pp_of_term v2; l = lcs t1 t2 in
(monom_mult (1 / lookup p v1) (l - t1) p) - (monom_mult (1 / lookup q v2) (l - t2) q)
else 0)"
definition (in ordered_term) is_Groebner_basis :: "('t ⇒⇩0 'b::field) set ⇒ bool"
where "is_Groebner_basis F ≡ relation.is_ChurchRosser (red F)"
subsection ‹Critical Pairs and S-Polynomials›
lemma crit_pair_same: "fst (crit_pair p p) = snd (crit_pair p p)"
by (simp add: crit_pair_def)
lemma crit_pair_swap: "crit_pair p q = (snd (crit_pair q p), fst (crit_pair q p))"
by (simp add: crit_pair_def lcs_comm)
lemma crit_pair_zero [simp]: "fst (crit_pair 0 q) = 0" and "snd (crit_pair p 0) = 0"
by (simp_all add: crit_pair_def)
lemma dgrad_p_set_le_crit_pair_zero: "dgrad_p_set_le d {fst (crit_pair p 0)} {p}"
proof (simp add: crit_pair_def lt_def[of 0] lcs_comm lcs_zero dgrad_p_set_le_def Keys_insert
min_term_def term_simps, intro conjI impI dgrad_set_leI)
fix s
assume "s ∈ pp_of_term ` keys (monom_mult (1 / lc p) 0 (tail p))"
then obtain v where "v ∈ keys (monom_mult (1 / lc p) 0 (tail p))" and "s = pp_of_term v" ..
from this(1) keys_monom_mult_subset have "v ∈ (⊕) 0 ` keys (tail p)" ..
hence "v ∈ keys (tail p)" by (simp add: image_iff term_simps)
hence "v ∈ keys p" by (simp add: keys_tail)
hence "s ∈ pp_of_term ` keys p" by (simp add: ‹s = pp_of_term v›)
moreover have "d s ≤ d s" ..
ultimately show "∃t∈pp_of_term ` keys p. d s ≤ d t" ..
qed simp
lemma dgrad_p_set_le_fst_crit_pair:
assumes "dickson_grading d"
shows "dgrad_p_set_le d {fst (crit_pair p q)} {p, q}"
proof (cases "q = 0")
case True
have "dgrad_p_set_le d {fst (crit_pair p q)} {p}" unfolding True
by (fact dgrad_p_set_le_crit_pair_zero)
also have "dgrad_p_set_le d ... {p, q}" by (rule dgrad_p_set_le_subset, simp)
finally show ?thesis .
next
case False
show ?thesis
proof (cases "p = 0")
case True
have "dgrad_p_set_le d {fst (crit_pair p q)} {q}"
by (simp add: True dgrad_p_set_le_def dgrad_set_le_def)
also have "dgrad_p_set_le d ... {p, q}" by (rule dgrad_p_set_le_subset, simp)
finally show ?thesis .
next
case False
show ?thesis
proof (simp add: dgrad_p_set_le_def Keys_insert crit_pair_def, intro conjI impI)
define t where "t = lcs (lp p) (lp q) - lp p"
let ?m = "monom_mult (1 / lc p) t (tail p)"
from assms have "dgrad_set_le d (pp_of_term ` keys ?m) (insert t (pp_of_term ` keys (tail p)))"
by (rule dgrad_set_le_monom_mult)
also have "dgrad_set_le d ... (pp_of_term ` (keys p ∪ keys q))"
proof (rule dgrad_set_leI, simp)
fix s
assume "s = t ∨ s ∈ pp_of_term ` keys (tail p)"
thus "∃v∈keys p ∪ keys q. d s ≤ d (pp_of_term v)"
proof
assume "s = t"
from assms have "d s ≤ ord_class.max (d (lp p)) (d (lp q))"
unfolding ‹s = t› t_def by (rule dickson_grading_lcs_minus)
hence "d s ≤ d (lp p) ∨ d s ≤ d (lp q)" by auto
thus ?thesis
proof
from ‹p ≠ 0› have "lt p ∈ keys p" by (rule lt_in_keys)
hence "lt p ∈ keys p ∪ keys q" by simp
moreover assume "d s ≤ d (lp p)"
ultimately show ?thesis ..
next
from ‹q ≠ 0› have "lt q ∈ keys q" by (rule lt_in_keys)
hence "lt q ∈ keys p ∪ keys q" by simp
moreover assume "d s ≤ d (lp q)"
ultimately show ?thesis ..
qed
next
assume "s ∈ pp_of_term ` keys (tail p)"
hence "s ∈ pp_of_term ` (keys p ∪ keys q)" by (auto simp: keys_tail)
then obtain v where "v ∈ keys p ∪ keys q" and "s = pp_of_term v" ..
note this(1)
moreover have "d s ≤ d (pp_of_term v)" by (simp add: ‹s = pp_of_term v›)
ultimately show ?thesis ..
qed
qed
finally show "dgrad_set_le d (pp_of_term ` keys ?m) (pp_of_term ` (keys p ∪ keys q))" .
qed (rule dgrad_set_leI, simp)
qed
qed
lemma dgrad_p_set_le_snd_crit_pair:
assumes "dickson_grading d"
shows "dgrad_p_set_le d {snd (crit_pair p q)} {p, q}"
by (simp add: crit_pair_swap[of p] insert_commute[of p q], rule dgrad_p_set_le_fst_crit_pair, fact)
lemma dgrad_p_set_closed_fst_crit_pair:
assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m"
shows "fst (crit_pair p q) ∈ dgrad_p_set d m"
proof -
from dgrad_p_set_le_fst_crit_pair[OF assms(1)] have "{fst (crit_pair p q)} ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
from assms(2, 3) show "{p, q} ⊆ dgrad_p_set d m" by simp
qed
thus ?thesis by simp
qed
lemma dgrad_p_set_closed_snd_crit_pair:
assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m"
shows "snd (crit_pair p q) ∈ dgrad_p_set d m"
by (simp add: crit_pair_swap[of p q], rule dgrad_p_set_closed_fst_crit_pair, fact+)
lemma fst_crit_pair_below_lcs:
"fst (crit_pair p q) ≺⇩p monomial 1 (term_of_pair (lcs (lp p) (lp q), component_of_term (lt p)))"
proof (cases "tail p = 0")
case True
thus ?thesis by (simp add: crit_pair_def ord_strict_p_monomial_iff)
next
case False
let ?t1 = "lp p"
let ?t2 = "lp q"
from False have "p ≠ 0" by auto
hence "lc p ≠ 0" by (rule lc_not_0)
hence "1 / lc p ≠ 0" by simp
from this False have "lt (monom_mult (1 / lc p) (lcs ?t1 ?t2 - ?t1) (tail p)) =
(lcs ?t1 ?t2 - ?t1) ⊕ lt (tail p)"
by (rule lt_monom_mult)
also from lt_tail[OF False] have "... ≺⇩t (lcs ?t1 ?t2 - ?t1) ⊕ lt p"
by (rule splus_mono_strict)
also from adds_lcs have "... = term_of_pair (lcs ?t1 ?t2, component_of_term (lt p))"
by (simp add: adds_lcs adds_minus splus_def)
finally show ?thesis by (auto simp add: crit_pair_def ord_strict_p_monomial_iff)
qed
lemma snd_crit_pair_below_lcs:
"snd (crit_pair p q) ≺⇩p monomial 1 (term_of_pair (lcs (lp p) (lp q), component_of_term (lt p)))"
proof (cases "component_of_term (lt p) = component_of_term (lt q)")
case True
show ?thesis
by (simp add: True crit_pair_swap[of p] lcs_comm[of "lp p"], fact fst_crit_pair_below_lcs)
next
case False
show ?thesis by (simp add: crit_pair_def False ord_strict_p_monomial_iff)
qed
lemma crit_pair_cbelow_same:
assumes "dickson_grading d" and "p ∈ dgrad_p_set d m"
shows "crit_pair_cbelow_on d m F p p"
proof (simp add: crit_pair_cbelow_on_def crit_pair_same cbelow_on_def term_simps, intro disjI1 conjI)
from assms(1) assms(2) assms(2) show "snd (crit_pair p p) ∈ dgrad_p_set d m"
by (rule dgrad_p_set_closed_snd_crit_pair)
next
from snd_crit_pair_below_lcs[of p p] show "snd (crit_pair p p) ≺⇩p monomial 1 (lt p)"
by (simp add: term_simps)
qed
lemma crit_pair_cbelow_distinct_component:
assumes "component_of_term (lt p) ≠ component_of_term (lt q)"
shows "crit_pair_cbelow_on d m F p q"
by (simp add: crit_pair_cbelow_on_def crit_pair_def assms cbelow_on_def
ord_strict_p_monomial_iff zero_in_dgrad_p_set)
lemma crit_pair_cbelow_sym:
assumes "crit_pair_cbelow_on d m F p q"
shows "crit_pair_cbelow_on d m F q p"
proof (cases "component_of_term (lt q) = component_of_term (lt p)")
case True
from assms show ?thesis
proof (simp add: crit_pair_cbelow_on_def crit_pair_swap[of p q] lcs_comm True,
elim cbelow_on_symmetric)
show "symp (λa b. red F a b ∨ red F b a)" by (simp add: symp_def)
qed
next
case False
thus ?thesis by (rule crit_pair_cbelow_distinct_component)
qed
lemma crit_pair_cs_imp_crit_pair_cbelow_on:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m"
and "q ∈ dgrad_p_set d m"
and "relation.cs (red F) (fst (crit_pair p q)) (snd (crit_pair p q))"
shows "crit_pair_cbelow_on d m F p q"
proof -
from assms(1) have "relation_order (red F) (≺⇩p) (dgrad_p_set d m)" by (rule is_relation_order_red)
moreover have "relation.dw_closed (red F) (dgrad_p_set d m)"
by (rule relation.dw_closedI, rule dgrad_p_set_closed_red, rule assms(1), rule assms(2))
moreover note assms(5)
moreover from assms(1) assms(3) assms(4) have "fst (crit_pair p q) ∈ dgrad_p_set d m"
by (rule dgrad_p_set_closed_fst_crit_pair)
moreover from assms(1) assms(3) assms(4) have "snd (crit_pair p q) ∈ dgrad_p_set d m"
by (rule dgrad_p_set_closed_snd_crit_pair)
moreover note fst_crit_pair_below_lcs snd_crit_pair_below_lcs
ultimately show ?thesis unfolding crit_pair_cbelow_on_def by (rule relation_order.cs_implies_cbelow_on)
qed
lemma crit_pair_cbelow_mono:
assumes "crit_pair_cbelow_on d m F p q" and "F ⊆ G"
shows "crit_pair_cbelow_on d m G p q"
using assms(1) unfolding crit_pair_cbelow_on_def
proof (induct rule: cbelow_on_induct)
case base
show ?case by (simp add: cbelow_on_def, intro disjI1 conjI, fact+)
next
case (step b c)
from step(2) have "red G b c ∨ red G c b" using red_subset[OF _ assms(2)] by blast
from step(5) step(3) this step(4) show ?case ..
qed
lemma lcs_red_single_fst_crit_pair:
assumes "p ≠ 0" and "component_of_term (lt p) = component_of_term (lt q)"
defines "t1 ≡ lp p"
defines "t2 ≡ lp q"
shows "red_single (monomial (- 1) (term_of_pair (lcs t1 t2, component_of_term (lt p))))
(fst (crit_pair p q)) p (lcs t1 t2 - t1)"
proof -
let ?l = "term_of_pair (lcs t1 t2, component_of_term (lt p))"
from assms(1) have "lc p ≠ 0" by (rule lc_not_0)
have "lt p adds⇩t ?l" by (simp add: adds_lcs adds_term_def t1_def term_simps)
hence eq1: "(lcs t1 t2 - t1) ⊕ lt p = ?l"
by (simp add: adds_lcs adds_minus splus_def t1_def)
with assms(1) show ?thesis
proof (simp add: crit_pair_def red_single_def assms(2))
have eq2: "monomial (- 1) ?l = monom_mult (- (1 / lc p)) (lcs t1 t2 - t1) (monomial (lc p) (lt p))"
by (simp add: monom_mult_monomial eq1 ‹lc p ≠ 0›)
show "monom_mult (1 / lc p) (lcs (lp p) (lp q) - lp p) (tail p) =
monomial (- 1) (term_of_pair (lcs t1 t2, component_of_term (lt q))) - monom_mult (- (1 / lc p)) (lcs t1 t2 - t1) p"
apply (simp add: t1_def t2_def monom_mult_dist_right_minus tail_alt_2 monom_mult_uminus_left)
by (metis assms(2) eq2 monom_mult_uminus_left t1_def t2_def)
qed
qed
corollary lcs_red_single_snd_crit_pair:
assumes "q ≠ 0" and "component_of_term (lt p) = component_of_term (lt q)"
defines "t1 ≡ lp p"
defines "t2 ≡ lp q"
shows "red_single (monomial (- 1) (term_of_pair (lcs t1 t2, component_of_term (lt p))))
(snd (crit_pair p q)) q (lcs t1 t2 - t2)"
by (simp add: crit_pair_swap[of p q] lcs_comm[of "lp p"] assms(2) t1_def t2_def,
rule lcs_red_single_fst_crit_pair, simp_all add: assms(1, 2))
lemma GB_imp_crit_pair_cbelow_dgrad_p_set:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "is_Groebner_basis F"
assumes "p ∈ F" and "q ∈ F" and "p ≠ 0" and "q ≠ 0"
shows "crit_pair_cbelow_on d m F p q"
proof (cases "component_of_term (lt p) = component_of_term (lt q)")
case True
from assms(1, 2) show ?thesis
proof (rule crit_pair_cs_imp_crit_pair_cbelow_on)
from assms(4, 2) show "p ∈ dgrad_p_set d m" ..
next
from assms(5, 2) show "q ∈ dgrad_p_set d m" ..
next
let ?cp = "crit_pair p q"
let ?l = "monomial (- 1) (term_of_pair (lcs (lp p) (lp q), component_of_term (lt p)))"
from assms(4) lcs_red_single_fst_crit_pair[OF assms(6) True] have "red F ?l (fst ?cp)"
by (rule red_setI)
hence 1: "(red F)⇧*⇧* ?l (fst ?cp)" ..
from assms(5) lcs_red_single_snd_crit_pair[OF assms(7) True] have "red F ?l (snd ?cp)"
by (rule red_setI)
hence 2: "(red F)⇧*⇧* ?l (snd ?cp)" ..
from assms(3) have "relation.is_confluent_on (red F) UNIV"
by (simp only: is_Groebner_basis_def relation.confluence_equiv_ChurchRosser[symmetric]
relation.is_confluent_def)
from this 1 2 show "relation.cs (red F) (fst ?cp) (snd ?cp)"
by (simp add: relation.is_confluent_on_def)
qed
next
case False
thus ?thesis by (rule crit_pair_cbelow_distinct_component)
qed
lemma spoly_alt:
assumes "p ≠ 0" and "q ≠ 0"
shows "spoly p q = fst (crit_pair p q) - snd (crit_pair p q)"
proof (cases "component_of_term (lt p) = component_of_term (lt q)")
case ec: True
show ?thesis
proof (rule poly_mapping_eqI, simp only: lookup_minus)
fix v
define t1 where "t1 = lp p"
define t2 where "t2 = lp q"
let ?l = "lcs t1 t2"
let ?lv = "term_of_pair (?l, component_of_term (lt p))"
let ?cp = "crit_pair p q"
let ?a = "λx. monom_mult (1 / lc p) (?l - t1) x"
let ?b = "λx. monom_mult (1 / lc q) (?l - t2) x"
have l_1: "(?l - t1) ⊕ lt p = ?lv" by (simp add: adds_lcs adds_minus splus_def t1_def)
have l_2: "(?l - t2) ⊕ lt q = ?lv" by (simp add: ec adds_lcs_2 adds_minus splus_def t2_def)
show "lookup (spoly p q) v = lookup (fst ?cp) v - lookup (snd ?cp) v"
proof (cases "v = ?lv")
case True
have v_1: "v = (?l - t1) ⊕ lt p" by (simp add: True l_1)
from ‹p ≠ 0› have "lt p ∈ keys p" by (rule lt_in_keys)
hence v_2: "v = (?l - t2) ⊕ lt q" by (simp add: True l_2)
from ‹q ≠ 0› have "lt q ∈ keys q" by (rule lt_in_keys)
from ‹lt p ∈ keys p› have "lookup (?a p) v = 1"
by (simp add: in_keys_iff v_1 lookup_monom_mult lc_def term_simps)
also from ‹lt q ∈ keys q› have "... = lookup (?b q) v"
by (simp add: in_keys_iff v_2 lookup_monom_mult lc_def term_simps)
finally have "lookup (spoly p q) v = 0"
by (simp add: spoly_def ec Let_def t1_def t2_def lookup_minus lc_def)
moreover have "lookup (fst ?cp) v = 0"
by (simp add: crit_pair_def ec v_1 lookup_monom_mult t1_def t2_def term_simps,
simp only: not_in_keys_iff_lookup_eq_zero[symmetric] keys_tail, simp)
moreover have "lookup (snd ?cp) v = 0"
by (simp add: crit_pair_def ec v_2 lookup_monom_mult t1_def t2_def term_simps,
simp only: not_in_keys_iff_lookup_eq_zero[symmetric] keys_tail, simp)
ultimately show ?thesis by simp
next
case False
have "lookup (?a (tail p)) v = lookup (?a p) v"
proof (cases "?l - t1 adds⇩p v")
case True
then obtain u where v: "v = (?l - t1) ⊕ u" ..
have "u ≠ lt p"
proof
assume "u = lt p"
hence "v = ?lv" by (simp add: v l_1)
with ‹v ≠ ?lv› show False ..
qed
thus ?thesis by (simp add: v lookup_monom_mult lookup_tail_2 term_simps)
next
case False
thus ?thesis by (simp add: lookup_monom_mult)
qed
moreover have "lookup (?b (tail q)) v = lookup (?b q) v"
proof (cases "?l - t2 adds⇩p v")
case True
then obtain u where v: "v = (?l - t2) ⊕ u" ..
have "u ≠ lt q"
proof
assume "u = lt q"
hence "v = ?lv" by (simp add: v l_2)
with ‹v ≠ ?lv› show False ..
qed
thus ?thesis by (simp add: v lookup_monom_mult lookup_tail_2 term_simps)
next
case False
thus ?thesis by (simp add: lookup_monom_mult)
qed
ultimately show ?thesis
by (simp add: ec spoly_def crit_pair_def lookup_minus t1_def t2_def Let_def lc_def)
qed
qed
next
case False
show ?thesis by (simp add: spoly_def crit_pair_def False)
qed
lemma spoly_same: "spoly p p = 0"
by (simp add: spoly_def)
lemma spoly_swap: "spoly p q = - spoly q p"
by (simp add: spoly_def lcs_comm Let_def)
lemma spoly_red_zero_imp_crit_pair_cbelow_on:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ dgrad_p_set d m"
and "q ∈ dgrad_p_set d m" and "p ≠ 0" and "q ≠ 0" and "(red F)⇧*⇧* (spoly p q) 0"
shows "crit_pair_cbelow_on d m F p q"
proof -
from assms(7) have "relation.cs (red F) (fst (crit_pair p q)) (snd (crit_pair p q))"
unfolding spoly_alt[OF assms(5) assms(6)] by (rule red_diff_rtrancl_cs)
with assms(1) assms(2) assms(3) assms(4) show ?thesis by (rule crit_pair_cs_imp_crit_pair_cbelow_on)
qed
lemma dgrad_p_set_le_spoly_zero: "dgrad_p_set_le d {spoly p 0} {p}"
proof (simp add: term_simps spoly_def lt_def[of 0] lcs_comm lcs_zero dgrad_p_set_le_def Keys_insert
Let_def min_term_def lc_def[symmetric], intro conjI impI dgrad_set_leI)
fix s
assume "s ∈ pp_of_term ` keys (monom_mult (1 / lc p) 0 p)"
then obtain u where "u ∈ keys (monom_mult (1 / lc p) 0 p)" and "s = pp_of_term u" ..
from this(1) keys_monom_mult_subset have "u ∈ (⊕) 0 ` keys p" ..
hence "u ∈ keys p" by (simp add: image_iff term_simps)
hence "s ∈ pp_of_term ` keys p" by (simp add: ‹s = pp_of_term u›)
moreover have "d s ≤ d s" ..
ultimately show "∃t∈pp_of_term ` keys p. d s ≤ d t" ..
qed simp
lemma dgrad_p_set_le_spoly:
assumes "dickson_grading d"
shows "dgrad_p_set_le d {spoly p q} {p, q}"
proof (cases "p = 0")
case True
have "dgrad_p_set_le d {spoly p q} {spoly q 0}" unfolding True spoly_swap[of 0 q]
by (fact dgrad_p_set_le_uminus)
also have "dgrad_p_set_le d ... {q}" by (fact dgrad_p_set_le_spoly_zero)
also have "dgrad_p_set_le d ... {p, q}" by (rule dgrad_p_set_le_subset, simp)
finally show ?thesis .
next
case False
show ?thesis
proof (cases "q = 0")
case True
have "dgrad_p_set_le d {spoly p q} {p}" unfolding True by (fact dgrad_p_set_le_spoly_zero)
also have "dgrad_p_set_le d ... {p, q}" by (rule dgrad_p_set_le_subset, simp)
finally show ?thesis .
next
case False
have "dgrad_p_set_le d {spoly p q} {fst (crit_pair p q), snd (crit_pair p q)}"
unfolding spoly_alt[OF ‹p ≠ 0› False] by (rule dgrad_p_set_le_minus)
also have "dgrad_p_set_le d ... {p, q}"
proof (rule dgrad_p_set_leI_insert)
from assms show "dgrad_p_set_le d {fst (crit_pair p q)} {p, q}"
by (rule dgrad_p_set_le_fst_crit_pair)
next
from assms show "dgrad_p_set_le d {snd (crit_pair p q)} {p, q}"
by (rule dgrad_p_set_le_snd_crit_pair)
qed
finally show ?thesis .
qed
qed
lemma dgrad_p_set_closed_spoly:
assumes "dickson_grading d" and "p ∈ dgrad_p_set d m" and "q ∈ dgrad_p_set d m"
shows "spoly p q ∈ dgrad_p_set d m"
proof -
from dgrad_p_set_le_spoly[OF assms(1)] have "{spoly p q} ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
from assms(2, 3) show "{p, q} ⊆ dgrad_p_set d m" by simp
qed
thus ?thesis by simp
qed
lemma components_spoly_subset: "component_of_term ` keys (spoly p q) ⊆ component_of_term ` Keys {p, q}"
unfolding spoly_def Let_def
proof (split if_split, intro conjI impI)
define c where "c = (1 / lookup p (lt p))"
define d where "d = (1 / lookup q (lt q))"
define s where "s = lcs (lp p) (lp q) - lp p"
define t where "t = lcs (lp p) (lp q) - lp q"
show "component_of_term ` keys (monom_mult c s p - monom_mult d t q) ⊆ component_of_term ` Keys {p, q}"
proof
fix k
assume "k ∈ component_of_term ` keys (monom_mult c s p - monom_mult d t q)"
then obtain v where "v ∈ keys (monom_mult c s p - monom_mult d t q)" and k: "k = component_of_term v" ..
from this(1) keys_minus have "v ∈ keys (monom_mult c s p) ∪ keys (monom_mult d t q)" ..
thus "k ∈ component_of_term ` Keys {p, q}"
proof
assume "v ∈ keys (monom_mult c s p)"
from this keys_monom_mult_subset have "v ∈ (⊕) s ` keys p" ..
then obtain u where "u ∈ keys p" and v: "v = s ⊕ u" ..
have "u ∈ Keys {p, q}" by (rule in_KeysI, fact, simp)
moreover have "k = component_of_term u" by (simp add: v k term_simps)
ultimately show ?thesis by simp
next
assume "v ∈ keys (monom_mult d t q)"
from this keys_monom_mult_subset have "v ∈ (⊕) t ` keys q" ..
then obtain u where "u ∈ keys q" and v: "v = t ⊕ u" ..
have "u ∈ Keys {p, q}" by (rule in_KeysI, fact, simp)
moreover have "k = component_of_term u" by (simp add: v k term_simps)
ultimately show ?thesis by simp
qed
qed
qed simp
lemma pmdl_closed_spoly:
assumes "p ∈ pmdl F" and "q ∈ pmdl F"
shows "spoly p q ∈ pmdl F"
proof (cases "component_of_term (lt p) = component_of_term (lt q)")
case True
show ?thesis
by (simp add: spoly_def True Let_def, rule pmdl.span_diff,
(rule pmdl_closed_monom_mult, fact)+)
next
case False
show ?thesis by (simp add: spoly_def False pmdl.span_zero)
qed
subsection ‹Buchberger's Theorem›
text ‹Before proving the main theorem of Gr\"obner bases theory for S-polynomials, as is usually done
in textbooks, we first prove it for critical pairs: a set ‹F› yields a confluent reduction
relation if the critical pairs of all ‹p ∈ F› and ‹q ∈ F› can be connected below
the least common sum of the leading power-products of ‹p› and ‹q›.
The reason why we proceed in this way is that it becomes much easier to prove the correctness of
Buchberger's second criterion for avoiding useless pairs.›
lemma crit_pair_cbelow_imp_confluent_dgrad_p_set:
assumes dg: "dickson_grading d" and "F ⊆ dgrad_p_set d m"
assumes main: "⋀p q. p ∈ F ⟹ q ∈ F ⟹ p ≠ 0 ⟹ q ≠ 0 ⟹ crit_pair_cbelow_on d m F p q"
shows "relation.is_confluent_on (red F) (dgrad_p_set d m)"
proof -
let ?A = "dgrad_p_set d m"
let ?R = "red F"
let ?RS = "λa b. red F a b ∨ red F b a"
let ?ord = "(≺⇩p)"
from dg have ro: "Confluence.relation_order ?R ?ord ?A"
by (rule is_relation_order_red)
have dw: "relation.dw_closed ?R ?A"
by (rule relation.dw_closedI, rule dgrad_p_set_closed_red, rule dg, rule assms(2))
show ?thesis
proof (rule relation_order.loc_connectivity_implies_confluence, fact ro)
show "is_loc_connective_on ?A ?ord ?R" unfolding is_loc_connective_on_def
proof (intro ballI allI impI)
fix a b1 b2 :: "'t ⇒⇩0 'b"
assume "a ∈ ?A"
assume "?R a b1 ∧ ?R a b2"
hence "?R a b1" and "?R a b2" by simp_all
hence "b1 ∈ ?A" and "b2 ∈ ?A" and "?ord b1 a" and "?ord b2 a"
using red_ord dgrad_p_set_closed_red[OF dg assms(2) ‹a ∈ ?A›] by blast+
from this(1) this(2) have "b1 - b2 ∈ ?A" by (rule dgrad_p_set_closed_minus)
from ‹red F a b1› obtain f1 and t1 where "f1 ∈ F" and r1: "red_single a b1 f1 t1" by (rule red_setE)
from ‹red F a b2› obtain f2 and t2 where "f2 ∈ F" and r2: "red_single a b2 f2 t2" by (rule red_setE)
from r1 r2 have "f1 ≠ 0" and "f2 ≠ 0" by (simp_all add: red_single_def)
hence lc1: "lc f1 ≠ 0" and lc2: "lc f2 ≠ 0" using lc_not_0 by auto
show "cbelow_on ?A ?ord a (λa b. ?R a b ∨ ?R b a) b1 b2"
proof (cases "t1 ⊕ lt f1 = t2 ⊕ lt f2")
case False
from confluent_distinct[OF r1 r2 False ‹f1 ∈ F› ‹f2 ∈ F›] obtain s
where s1: "(red F)⇧*⇧* b1 s" and s2: "(red F)⇧*⇧* b2 s" .
have "relation.cs ?R b1 b2" unfolding relation.cs_def by (intro exI conjI, fact s1, fact s2)
from ro dw this ‹b1 ∈ ?A› ‹b2 ∈ ?A› ‹?ord b1 a› ‹?ord b2 a› show ?thesis
by (rule relation_order.cs_implies_cbelow_on)
next
case True
hence ec: "component_of_term (lt f1) = component_of_term (lt f2)"
by (metis component_of_term_splus)
let ?l1 = "lp f1"
let ?l2 = "lp f2"
define v where "v ≡ t2 ⊕ lt f2"
define l where "l ≡ lcs ?l1 ?l2"
define a' where "a' = except a {v}"
define ma where "ma = monomial (lookup a v) v"
have v_alt: "v = t1 ⊕ lt f1" by (simp only: True v_def)
have "a = ma + a'" unfolding ma_def a'_def by (fact plus_except)
have comp_f1: "component_of_term (lt f1) = component_of_term v" by (simp add: v_alt term_simps)
have "?l1 adds l" unfolding l_def by (rule adds_lcs)
have "?l2 adds l" unfolding l_def by (rule adds_lcs_2)
have "?l1 adds⇩p (t1 ⊕ lt f1)" by (simp add: adds_pp_splus term_simps)
hence "?l1 adds⇩p v" by (simp add: v_alt)
have "?l2 adds⇩p v" by (simp add: v_def adds_pp_splus term_simps)
from ‹?l1 adds⇩p v› ‹?l2 adds⇩p v› have "l adds⇩p v" by (simp add: l_def adds_pp_def lcs_adds)
have "pp_of_term (v ⊖ ?l1) = t1" by (simp add: v_alt term_simps)
with ‹l adds⇩p v› ‹?l1 adds l› have tf1': "pp_of_term ((l - ?l1) ⊕ (v ⊖ l)) = t1"
by (simp add: minus_splus_sminus_cancel)
hence tf1: "((pp_of_term v) - l) + (l - ?l1) = t1" by (simp add: add.commute term_simps)
have "pp_of_term (v ⊖ ?l2) = t2" by (simp add: v_def term_simps)
with ‹l adds⇩p v› ‹?l2 adds l› have tf2': "pp_of_term ((l - ?l2) ⊕ (v ⊖ l)) = t2"
by (simp add: minus_splus_sminus_cancel)
hence tf2: "((pp_of_term v) - l) + (l - ?l2) = t2" by (simp add: add.commute term_simps)
let ?ca = "lookup a v"
let ?v = "pp_of_term v - l"
have "?v + l = pp_of_term v" using ‹l adds⇩p v› adds_minus adds_pp_def by blast
from tf1' have "?v adds t1" unfolding pp_of_term_splus add.commute[of "l - ?l1"] pp_of_term_sminus
using addsI by blast
with dg have "d ?v ≤ d t1" by (rule dickson_grading_adds_imp_le)
also from dg ‹a ∈ ?A› r1 have "... ≤ m" by (rule dgrad_p_set_red_single_pp)
finally have "d ?v ≤ m" .
from r2 have "?ca ≠ 0" by (simp add: red_single_def v_def)
hence "- ?ca ≠ 0" by simp
from r1 have "b1 = a - monom_mult (?ca / lc f1) t1 f1" by (simp add: red_single_def v_alt)
also have "... = monom_mult (- ?ca) ?v (fst (crit_pair f1 f2)) + a'"
proof (simp add: a'_def ec crit_pair_def l_def[symmetric] monom_mult_assoc tf1,
rule poly_mapping_eqI, simp add: lookup_add lookup_minus)
fix u
show "lookup a u - lookup (monom_mult (?ca / lc f1) t1 f1) u =
lookup (monom_mult (- (?ca / lc f1)) t1 (tail f1)) u + lookup (except a {v}) u"
proof (cases "u = v")
case True
show ?thesis
by (simp add: True lookup_except v_alt lookup_monom_mult lookup_tail_2 lc_def[symmetric] lc1 term_simps)
next
case False
hence "u ∉ {v}" by simp
moreover
{
assume "t1 adds⇩p u"
hence "t1 ⊕ (u ⊖ t1) = u" by (simp add: adds_pp_sminus)
hence "u ⊖ t1 ≠ lt f1" using False v_alt by auto
hence "lookup f1 (u ⊖ t1) = lookup (tail f1) (u ⊖ t1)" by (simp add: lookup_tail_2)
}
ultimately show ?thesis using False by (simp add: lookup_except lookup_monom_mult)
qed
qed
finally have b1: "b1 = monom_mult (- ?ca) ?v (fst (crit_pair f1 f2)) + a'" .
from r2 have "b2 = a - monom_mult (?ca / lc f2) t2 f2"
by (simp add: red_single_def v_def True)
also have "... = monom_mult (- ?ca) ?v (snd (crit_pair f1 f2)) + a'"
proof (simp add: a'_def ec crit_pair_def l_def[symmetric] monom_mult_assoc tf2,
rule poly_mapping_eqI, simp add: lookup_add lookup_minus)
fix u
show "lookup a u - lookup (monom_mult (?ca / lc f2) t2 f2) u =
lookup (monom_mult (- (?ca / lc f2)) t2 (tail f2)) u + lookup (except a {v}) u"
proof (cases "u = v")
case True
show ?thesis
by (simp add: True lookup_except v_def lookup_monom_mult lookup_tail_2 lc_def[symmetric] lc2 term_simps)
next
case False
hence "u ∉ {v}" by simp
moreover
{
assume "t2 adds⇩p u"
hence "t2 ⊕ (u ⊖ t2) = u" by (simp add: adds_pp_sminus)
hence "u ⊖ t2 ≠ lt f2" using False v_def by auto
hence "lookup f2 (u ⊖ t2) = lookup (tail f2) (u ⊖ t2)" by (simp add: lookup_tail_2)
}
ultimately show ?thesis using False by (simp add: lookup_except lookup_monom_mult)
qed
qed
finally have b2: "b2 = monom_mult (- ?ca) ?v (snd (crit_pair f1 f2)) + a'" .
let ?lv = "term_of_pair (l, component_of_term (lt f1))"
from ‹f1 ∈ F› ‹f2 ∈ F› ‹f1 ≠ 0› ‹f2 ≠ 0› have "crit_pair_cbelow_on d m F f1 f2" by (rule main)
hence "cbelow_on ?A ?ord (monomial 1 ?lv) ?RS (fst (crit_pair f1 f2)) (snd (crit_pair f1 f2))"
by (simp only: crit_pair_cbelow_on_def l_def)
with dg assms (2) ‹d ?v ≤ m› ‹- ?ca ≠ 0›
have "cbelow_on ?A ?ord (monom_mult (- ?ca) ?v (monomial 1 ?lv)) ?RS
(monom_mult (- ?ca) ?v (fst (crit_pair f1 f2)))
(monom_mult (- ?ca) ?v (snd (crit_pair f1 f2)))"
by (rule cbelow_on_monom_mult)
hence "cbelow_on ?A ?ord (monomial (- ?ca) v) ?RS
(monom_mult (- ?ca) ?v (fst (crit_pair f1 f2)))
(monom_mult (- ?ca) ?v (snd (crit_pair f1 f2)))"
by (simp add: monom_mult_monomial ‹(pp_of_term v - l) + l = pp_of_term v› splus_def comp_f1 term_simps)
with ‹?ca ≠ 0› have "cbelow_on ?A ?ord (monomial ?ca (0 ⊕ v)) ?RS
(monom_mult (-?ca) ?v (fst (crit_pair f1 f2))) (monom_mult (-?ca) ?v (snd (crit_pair f1 f2)))"
by (rule cbelow_on_monom_mult_monomial)
hence "cbelow_on ?A ?ord ma ?RS
(monom_mult (-?ca) ?v (fst (crit_pair f1 f2))) (monom_mult (-?ca) ?v (snd (crit_pair f1 f2)))"
by (simp add: ma_def term_simps)
with dg assms(2) _ _
show "cbelow_on ?A ?ord a ?RS b1 b2" unfolding ‹a = ma + a'› b1 b2
proof (rule cbelow_on_plus)
show "a' ∈ ?A"
by (rule, simp add: a'_def keys_except, erule conjE, intro dgrad_p_setD,
rule ‹a ∈ dgrad_p_set d m›)
next
show "keys a' ∩ keys ma = {}" by (simp add: ma_def a'_def keys_except)
qed
qed
qed
qed fact
qed
corollary crit_pair_cbelow_imp_GB_dgrad_p_set:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m"
assumes "⋀p q. p ∈ F ⟹ q ∈ F ⟹ p ≠ 0 ⟹ q ≠ 0 ⟹ crit_pair_cbelow_on d m F p q"
shows "is_Groebner_basis F"
unfolding is_Groebner_basis_def
proof (rule relation.confluence_implies_ChurchRosser,
simp only: relation.is_confluent_def relation.is_confluent_on_def, intro ballI allI impI)
fix a b1 b2
assume a: "(red F)⇧*⇧* a b1 ∧ (red F)⇧*⇧* a b2"
from assms(2) obtain n where "m ≤ n" and "a ∈ dgrad_p_set d n" and "F ⊆ dgrad_p_set d n"
by (rule dgrad_p_set_insert)
{
fix p q
assume "p ∈ F" and "q ∈ F" and "p ≠ 0" and "q ≠ 0"
hence "crit_pair_cbelow_on d m F p q" by (rule assms(3))
from this dgrad_p_set_subset[OF ‹m ≤ n›] have "crit_pair_cbelow_on d n F p q"
unfolding crit_pair_cbelow_on_def by (rule cbelow_on_mono)
}
with assms(1) ‹F ⊆ dgrad_p_set d n› have "relation.is_confluent_on (red F) (dgrad_p_set d n)"
by (rule crit_pair_cbelow_imp_confluent_dgrad_p_set)
from this ‹a ∈ dgrad_p_set d n› have "∀b1 b2. (red F)⇧*⇧* a b1 ∧ (red F)⇧*⇧* a b2 ⟶ relation.cs (red F) b1 b2"
unfolding relation.is_confluent_on_def ..
with a show "relation.cs (red F) b1 b2" by blast
qed
corollary Buchberger_criterion_dgrad_p_set:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m"
assumes "⋀p q. p ∈ F ⟹ q ∈ F ⟹ p ≠ 0 ⟹ q ≠ 0 ⟹ p ≠ q ⟹
component_of_term (lt p) = component_of_term (lt q) ⟹ (red F)⇧*⇧* (spoly p q) 0"
shows "is_Groebner_basis F"
using assms(1) assms(2)
proof (rule crit_pair_cbelow_imp_GB_dgrad_p_set)
fix p q
assume "p ∈ F" and "q ∈ F" and "p ≠ 0" and "q ≠ 0"
from this(1, 2) assms(2) have p: "p ∈ dgrad_p_set d m" and q: "q ∈ dgrad_p_set d m" by auto
show "crit_pair_cbelow_on d m F p q"
proof (cases "p = q")
case True
from assms(1) q show ?thesis unfolding True by (rule crit_pair_cbelow_same)
next
case False
show ?thesis
proof (cases "component_of_term (lt p) = component_of_term (lt q)")
case True
from assms(1) assms(2) p q ‹p ≠ 0› ‹q ≠ 0› show "crit_pair_cbelow_on d m F p q"
proof (rule spoly_red_zero_imp_crit_pair_cbelow_on)
from ‹p ∈ F› ‹q ∈ F› ‹p ≠ 0› ‹q ≠ 0› ‹p ≠ q› True show "(red F)⇧*⇧* (spoly p q) 0"
by (rule assms(3))
qed
next
case False
thus ?thesis by (rule crit_pair_cbelow_distinct_component)
qed
qed
qed
lemmas Buchberger_criterion_finite = Buchberger_criterion_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemma (in ordered_term) GB_imp_zero_reducibility:
assumes "is_Groebner_basis G" and "f ∈ pmdl G"
shows "(red G)⇧*⇧* f 0"
proof -
from in_pmdl_srtc[OF ‹f ∈ pmdl G›] ‹is_Groebner_basis G› have "relation.cs (red G) f 0"
unfolding is_Groebner_basis_def relation.is_ChurchRosser_def by simp
then obtain s where rfs: "(red G)⇧*⇧* f s" and r0s: "(red G)⇧*⇧* 0 s" unfolding relation.cs_def by auto
from rtrancl_0[OF r0s] and rfs show ?thesis by simp
qed
lemma (in ordered_term) GB_imp_reducibility:
assumes "is_Groebner_basis G" and "f ≠ 0" and "f ∈ pmdl G"
shows "is_red G f"
using assms by (meson GB_imp_zero_reducibility is_red_def relation.rtrancl_is_final)
lemma is_Groebner_basis_empty: "is_Groebner_basis {}"
by (rule Buchberger_criterion_finite, rule, simp)
lemma is_Groebner_basis_singleton: "is_Groebner_basis {f}"
by (rule Buchberger_criterion_finite, simp, simp add: spoly_same)
subsection ‹Buchberger's Criteria for Avoiding Useless Pairs›
text ‹Unfortunately, the product criterion is only applicable to scalar polynomials.›
lemma (in gd_powerprod) product_criterion:
assumes "dickson_grading d" and "F ⊆ punit.dgrad_p_set d m" and "p ∈ F" and "q ∈ F"
and "p ≠ 0" and "q ≠ 0" and "gcs (punit.lt p) (punit.lt q) = 0"
shows "punit.crit_pair_cbelow_on d m F p q"
proof -
let ?lt = "punit.lt p"
let ?lq = "punit.lt q"
let ?l = "lcs ?lt ?lq"
define s where "s = punit.monom_mult (- 1 / (punit.lc p * punit.lc q)) 0 (punit.tail p * punit.tail q)"
from assms(7) have "?l = ?lt + ?lq" by (metis add_cancel_left_left gcs_plus_lcs)
hence "?l - ?lt = ?lq" and "?l - ?lq = ?lt" by simp_all
have "(punit.red {q})⇧*⇧* (punit.tail p * (monomial (1 / punit.lc p) (punit.lt q)))
(punit.monom_mult (- (1 / punit.lc p) / punit.lc q) 0 (punit.tail p * punit.tail q))"
unfolding punit_mult_scalar[symmetric] using ‹q ≠ 0› by (rule punit.red_mult_scalar_lt)
moreover have "punit.monom_mult (1 / punit.lc p) (punit.lt q) (punit.tail p) =
punit.tail p * (monomial (1 / punit.lc p) (punit.lt q))"
by (simp add: times_monomial_left[symmetric])
ultimately have "(punit.red {q})⇧*⇧* (fst (punit.crit_pair p q)) s"
by (simp add: punit.crit_pair_def ‹?l - ?lt = ?lq› s_def)
moreover from ‹q ∈ F› have "{q} ⊆ F" by simp
ultimately have 1: "(punit.red F)⇧*⇧* (fst (punit.crit_pair p q)) s" by (rule punit.red_rtrancl_subset)
have "(punit.red {p})⇧*⇧* (punit.tail q * (monomial (1 / punit.lc q) (punit.lt p)))
(punit.monom_mult (- (1 / punit.lc q) / punit.lc p) 0 (punit.tail q * punit.tail p))"
unfolding punit_mult_scalar[symmetric] using ‹p ≠ 0› by (rule punit.red_mult_scalar_lt)
hence "(punit.red {p})⇧*⇧* (snd (punit.crit_pair p q)) s"
by (simp add: punit.crit_pair_def ‹?l - ?lq = ?lt› s_def mult.commute flip: times_monomial_left)
moreover from ‹p ∈ F› have "{p} ⊆ F" by simp
ultimately have 2: "(punit.red F)⇧*⇧* (snd (punit.crit_pair p q)) s" by (rule punit.red_rtrancl_subset)
note assms(1) assms(2)
moreover from ‹p ∈ F› ‹F ⊆ punit.dgrad_p_set d m› have "p ∈ punit.dgrad_p_set d m" ..
moreover from ‹q ∈ F› ‹F ⊆ punit.dgrad_p_set d m› have "q ∈ punit.dgrad_p_set d m" ..
moreover from 1 2 have "relation.cs (punit.red F) (fst (punit.crit_pair p q)) (snd (punit.crit_pair p q))"
unfolding relation.cs_def by blast
ultimately show ?thesis by (rule punit.crit_pair_cs_imp_crit_pair_cbelow_on)
qed
lemma chain_criterion:
assumes "dickson_grading d" and "F ⊆ dgrad_p_set d m" and "p ∈ F" and "q ∈ F"
and "p ≠ 0" and "q ≠ 0" and "lp r adds lcs (lp p) (lp q)"
and "component_of_term (lt r) = component_of_term (lt p)"
and pr: "crit_pair_cbelow_on d m F p r" and rq: "crit_pair_cbelow_on d m F r q"
shows "crit_pair_cbelow_on d m F p q"
proof (cases "component_of_term (lt p) = component_of_term (lt q)")
case True
with assms(8) have comp_r: "component_of_term (lt r) = component_of_term (lt q)" by simp
let ?A = "dgrad_p_set d m"
let ?RS = "λa b. red F a b ∨ red F b a"
let ?lt = "lp p"
let ?lq = "lp q"
let ?lr = "lp r"
let ?ltr = "lcs ?lt ?lr"
let ?lrq = "lcs ?lr ?lq"
let ?ltq = "lcs ?lt ?lq"
from ‹p ∈ F› ‹F ⊆ dgrad_p_set d m› have "p ∈ dgrad_p_set d m" ..
from this ‹p ≠ 0› have "d ?lt ≤ m" by (rule dgrad_p_setD_lp)
from ‹q ∈ F› ‹F ⊆ dgrad_p_set d m› have "q ∈ dgrad_p_set d m" ..
from this ‹q ≠ 0› have "d ?lq ≤ m" by (rule dgrad_p_setD_lp)
from assms(1) have "d ?ltq ≤ ord_class.max (d ?lt) (d ?lq)" by (rule dickson_grading_lcs)
also from ‹d ?lt ≤ m› ‹d ?lq ≤ m› have "... ≤ m" by simp
finally have "d ?ltq ≤ m" .
from adds_lcs ‹?lr adds ?ltq› have "?ltr adds ?ltq" by (rule lcs_adds)
then obtain up where "?ltq = ?ltr + up" ..
hence up1: "?ltq - ?lt = up + (?ltr - ?lt)" and up2: "up + (?ltr - ?lr) = ?ltq - ?lr"
by (metis add.commute adds_lcs minus_plus, metis add.commute adds_lcs_2 minus_plus)
have fst_pq: "fst (crit_pair p q) = monom_mult 1 up (fst (crit_pair p r))"
by (simp add: crit_pair_def monom_mult_assoc up1 True comp_r)
from assms(1) assms(2) _ _ pr
have "cbelow_on ?A (≺⇩p) (monom_mult 1 up (monomial 1 (term_of_pair (?ltr, component_of_term (lt p))))) ?RS
(fst (crit_pair p q)) (monom_mult 1 up (snd (crit_pair p r)))"
unfolding fst_pq crit_pair_cbelow_on_def
proof (rule cbelow_on_monom_mult)
from ‹d ?ltq ≤ m› show "d up ≤ m" by (simp add: ‹?ltq = ?ltr + up› dickson_gradingD1[OF assms(1)])
qed simp
hence 1: "cbelow_on ?A (≺⇩p) (monomial 1 (term_of_pair (?ltq, component_of_term (lt p)))) ?RS
(fst (crit_pair p q)) (monom_mult 1 up (snd (crit_pair p r)))"
by (simp add: monom_mult_monomial ‹?ltq = ?ltr + up› add.commute splus_def term_simps)
from ‹?lr adds ?ltq› adds_lcs_2 have "?lrq adds ?ltq" by (rule lcs_adds)
then obtain uq where "?ltq = ?lrq + uq" ..
hence uq1: "?ltq - ?lq = uq + (?lrq - ?lq)" and uq2: "uq + (?lrq - ?lr) = ?ltq - ?lr"
by (metis add.commute adds_lcs_2 minus_plus, metis add.commute adds_lcs minus_plus)
have eq: "monom_mult 1 uq (fst (crit_pair r q)) = monom_mult 1 up (snd (crit_pair p r))"
by (simp add: crit_pair_def monom_mult_assoc up2 uq2 True comp_r)
have snd_pq: "snd (crit_pair p q) = monom_mult 1 uq (snd (crit_pair r q))"
by (simp add: crit_pair_def monom_mult_assoc uq1 True comp_r)
from assms(1) assms(2) _ _ rq
have "cbelow_on ?A (≺⇩p) (monom_mult 1 uq (monomial 1 (term_of_pair (?lrq, component_of_term (lt p))))) ?RS
(monom_mult 1 uq (fst (crit_pair r q))) (snd (crit_pair p q))"
unfolding snd_pq crit_pair_cbelow_on_def assms(8)
proof (rule cbelow_on_monom_mult)
from ‹d ?ltq ≤ m› show "d uq ≤ m" by (simp add: ‹?ltq = ?lrq + uq› dickson_gradingD1[OF assms(1)])
qed simp
hence "cbelow_on ?A (≺⇩p) (monomial 1 (term_of_pair (?ltq, component_of_term (lt p)))) ?RS
(monom_mult 1 uq (fst (crit_pair r q))) (snd (crit_pair p q))"
by (simp add: monom_mult_monomial ‹?ltq = ?lrq + uq› add.commute splus_def term_simps)
hence "cbelow_on ?A (≺⇩p) (monomial 1 (term_of_pair (?ltq, component_of_term (lt p)))) ?RS
(monom_mult 1 up (snd (crit_pair p r))) (snd (crit_pair p q))"
by (simp only: eq)
with 1 show ?thesis unfolding crit_pair_cbelow_on_def by (rule cbelow_on_transitive)
next
case False
thus ?thesis by (rule crit_pair_cbelow_distinct_component)
qed
subsection ‹Weak and Strong Gr\"obner Bases›
lemma ord_p_wf_on:
assumes "dickson_grading d"
shows "wfp_on (≺⇩p) (dgrad_p_set d m)"
proof (rule wfp_onI_min)
fix x::"'t ⇒⇩0 'b" and Q
assume "x ∈ Q" and "Q ⊆ dgrad_p_set d m"
with assms obtain z where "z ∈ Q" and *: "⋀y. y ≺⇩p z ⟹ y ∉ Q"
by (rule ord_p_minimum_dgrad_p_set, blast)
from this(1) show "∃z∈Q. ∀y∈dgrad_p_set d m. y ≺⇩p z ⟶ y ∉ Q"
proof
show "∀y∈dgrad_p_set d m. y ≺⇩p z ⟶ y ∉ Q" by (intro ballI impI *)
qed
qed
lemma is_red_implies_0_red_dgrad_p_set:
assumes "dickson_grading d" and "B ⊆ dgrad_p_set d m"
assumes "pmdl B ⊆ pmdl A" and "⋀q. q ∈ pmdl A ⟹ q ∈ dgrad_p_set d m ⟹ q ≠ 0 ⟹ is_red B q"
and "p ∈ pmdl A" and "p ∈ dgrad_p_set d m"
shows "(red B)⇧*⇧* p 0"
proof -
from ord_p_wf_on[OF assms(1)] assms(6, 5) show ?thesis
proof (induction p rule: wfp_on_induct)
case (less p)
show ?case
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
from assms(4)[OF less(3, 1) False] obtain q where redpq: "red B p q" unfolding is_red_alt ..
with assms(1) assms(2) less(1) have "q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red)
moreover from redpq have "q ≺⇩p p" by (rule red_ord)
moreover from ‹pmdl B ⊆ pmdl A› ‹p ∈ pmdl A› ‹red B p q› have "q ∈ pmdl A"
by (rule pmdl_closed_red)
ultimately have "(red B)⇧*⇧* q 0" by (rule less(2))
show ?thesis by (rule converse_rtranclp_into_rtranclp, rule redpq, fact)
qed
qed
qed
lemma is_red_implies_0_red_dgrad_p_set':
assumes "dickson_grading d" and "B ⊆ dgrad_p_set d m"
assumes "pmdl B ⊆ pmdl A" and "⋀q. q ∈ pmdl A ⟹ q ≠ 0 ⟹ is_red B q"
and "p ∈ pmdl A"
shows "(red B)⇧*⇧* p 0"
proof -
from assms(2) obtain n where "m ≤ n" and "p ∈ dgrad_p_set d n" and B: "B ⊆ dgrad_p_set d n"
by (rule dgrad_p_set_insert)
from ord_p_wf_on[OF assms(1)] this(2) assms(5) show ?thesis
proof (induction p rule: wfp_on_induct)
case (less p)
show ?case
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
from assms(4)[OF ‹p ∈ (pmdl A)› False] obtain q where redpq: "red B p q" unfolding is_red_alt ..
with assms(1) B ‹p ∈ dgrad_p_set d n› have "q ∈ dgrad_p_set d n" by (rule dgrad_p_set_closed_red)
moreover from redpq have "q ≺⇩p p" by (rule red_ord)
moreover from ‹pmdl B ⊆ pmdl A› ‹p ∈ pmdl A› ‹red B p q› have "q ∈ pmdl A"
by (rule pmdl_closed_red)
ultimately have "(red B)⇧*⇧* q 0" by (rule less(2))
show ?thesis by (rule converse_rtranclp_into_rtranclp, rule redpq, fact)
qed
qed
qed
lemma pmdl_eqI_adds_lt_dgrad_p_set:
fixes G::"('t ⇒⇩0 'b::field) set"
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" and "B ⊆ dgrad_p_set d m" and "pmdl G ⊆ pmdl B"
assumes "⋀f. f ∈ pmdl B ⟹ f ∈ dgrad_p_set d m ⟹ f ≠ 0 ⟹ (∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)"
shows "pmdl G = pmdl B"
proof
show "pmdl B ⊆ pmdl G"
proof (rule pmdl.span_subset_spanI, rule)
fix p
assume "p ∈ B"
hence "p ∈ pmdl B" and "p ∈ dgrad_p_set d m" by (rule pmdl.span_base, rule, intro assms(3))
with assms(1, 2, 4) _ have "(red G)⇧*⇧* p 0"
proof (rule is_red_implies_0_red_dgrad_p_set)
fix f
assume "f ∈ pmdl B" and "f ∈ dgrad_p_set d m" and "f ≠ 0"
hence "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" by (rule assms(5))
then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by blast
thus "is_red G f" using ‹f ≠ 0› is_red_indI1 by blast
qed
thus "p ∈ pmdl G" by (rule red_rtranclp_0_in_pmdl)
qed
qed fact
lemma pmdl_eqI_adds_lt_dgrad_p_set':
fixes G::"('t ⇒⇩0 'b::field) set"
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" and "pmdl G ⊆ pmdl B"
assumes "⋀f. f ∈ pmdl B ⟹ f ≠ 0 ⟹ (∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)"
shows "pmdl G = pmdl B"
proof
show "pmdl B ⊆ pmdl G"
proof
fix p
assume "p ∈ pmdl B"
with assms(1, 2, 3) _ have "(red G)⇧*⇧* p 0"
proof (rule is_red_implies_0_red_dgrad_p_set')
fix f
assume "f ∈ pmdl B" and "f ≠ 0"
hence "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" by (rule assms(4))
then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by blast
thus "is_red G f" using ‹f ≠ 0› is_red_indI1 by blast
qed
thus "p ∈ pmdl G" by (rule red_rtranclp_0_in_pmdl)
qed
qed fact
lemma GB_implies_unique_nf_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes isGB: "is_Groebner_basis G"
shows "∃! h. (red G)⇧*⇧* f h ∧ ¬ is_red G h"
proof -
from assms(1) assms(2) have "wfP (red G)¯¯" by (rule red_wf_dgrad_p_set)
then obtain h where ftoh: "(red G)⇧*⇧* f h" and irredh: "relation.is_final (red G) h"
by (rule relation.wf_imp_nf_ex)
show ?thesis
proof
from ftoh and irredh show "(red G)⇧*⇧* f h ∧ ¬ is_red G h" by (simp add: is_red_def)
next
fix h'
assume "(red G)⇧*⇧* f h' ∧ ¬ is_red G h'"
hence ftoh': "(red G)⇧*⇧* f h'" and irredh': "relation.is_final (red G) h'" by (simp_all add: is_red_def)
show "h' = h"
proof (rule relation.ChurchRosser_unique_final)
from isGB show "relation.is_ChurchRosser (red G)" by (simp only: is_Groebner_basis_def)
qed fact+
qed
qed
lemma translation_property':
assumes "p ≠ 0" and red_p_0: "(red F)⇧*⇧* p 0"
shows "is_red F (p + q) ∨ is_red F q"
proof (rule disjCI)
assume not_red: "¬ is_red F q"
from red_p_0 ‹p ≠ 0› obtain f where "f ∈ F" and "f ≠ 0" and lt_adds: "lt f adds⇩t lt p"
by (rule zero_reducibility_implies_lt_divisibility)
show "is_red F (p + q)"
proof (cases "q = 0")
case True
with is_red_indI1[OF ‹f ∈ F› ‹f ≠ 0› ‹p ≠ 0› lt_adds] show ?thesis by simp
next
case False
from not_red is_red_addsI[OF ‹f ∈ F› ‹f ≠ 0› _ lt_adds, of q] have "¬ lt p ∈ (keys q)" by blast
hence "lookup q (lt p) = 0" by (simp add: in_keys_iff)
with lt_in_keys[OF ‹p ≠ 0›] have "lt p ∈ (keys (p + q))" unfolding in_keys_iff by (simp add: lookup_add)
from is_red_addsI[OF ‹f ∈ F› ‹f ≠ 0› this lt_adds] show ?thesis .
qed
qed
lemma translation_property:
assumes "p ≠ q" and red_0: "(red F)⇧*⇧* (p - q) 0"
shows "is_red F p ∨ is_red F q"
proof -
from ‹p ≠ q› have "p - q ≠ 0" by simp
from translation_property'[OF this red_0, of q] show ?thesis by simp
qed
lemma weak_GB_is_strong_GB_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes "⋀f. f ∈ pmdl G ⟹ f ∈ dgrad_p_set d m ⟹ (red G)⇧*⇧* f 0"
shows "is_Groebner_basis G"
using assms(1, 2)
proof (rule Buchberger_criterion_dgrad_p_set)
fix p q
assume "p ∈ G" and "q ∈ G"
hence "p ∈ pmdl G" and "q ∈ pmdl G" by (auto intro: pmdl.span_base)
hence "spoly p q ∈ pmdl G" by (rule pmdl_closed_spoly)
thus "(red G)⇧*⇧* (spoly p q) 0"
proof (rule assms(3))
note assms(1)
moreover from ‹p ∈ G› assms(2) have "p ∈ dgrad_p_set d m" ..
moreover from ‹q ∈ G› assms(2) have "q ∈ dgrad_p_set d m" ..
ultimately show "spoly p q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_spoly)
qed
qed
lemma weak_GB_is_strong_GB:
assumes "⋀f. f ∈ (pmdl G) ⟹ (red G)⇧*⇧* f 0"
shows "is_Groebner_basis G"
unfolding is_Groebner_basis_def
proof (rule relation.confluence_implies_ChurchRosser,
simp add: relation.is_confluent_def relation.is_confluent_on_def, intro allI impI, erule conjE)
fix f p q
assume "(red G)⇧*⇧* f p" and "(red G)⇧*⇧* f q"
hence "relation.srtc (red G) p q"
by (meson relation.rtc_implies_srtc relation.srtc_symmetric relation.srtc_transitive)
hence "p - q ∈ pmdl G" by (rule srtc_in_pmdl)
hence "(red G)⇧*⇧* (p - q) 0" by (rule assms)
thus "relation.cs (red G) p q" by (rule red_diff_rtrancl_cs)
qed
corollary GB_alt_1_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
shows "is_Groebner_basis G ⟷ (∀f ∈ pmdl G. f ∈ dgrad_p_set d m ⟶ (red G)⇧*⇧* f 0)"
using weak_GB_is_strong_GB_dgrad_p_set[OF assms] GB_imp_zero_reducibility by blast
corollary GB_alt_1: "is_Groebner_basis G ⟷ (∀f ∈ pmdl G. (red G)⇧*⇧* f 0)"
using weak_GB_is_strong_GB GB_imp_zero_reducibility by blast
lemma isGB_I_is_red:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes "⋀f. f ∈ pmdl G ⟹ f ∈ dgrad_p_set d m ⟹ f ≠ 0 ⟹ is_red G f"
shows "is_Groebner_basis G"
unfolding GB_alt_1_dgrad_p_set[OF assms(1, 2)]
proof (intro ballI impI)
fix f
assume "f ∈ pmdl G" and "f ∈ dgrad_p_set d m"
with assms(1, 2) subset_refl assms(3) show "(red G)⇧*⇧* f 0"
by (rule is_red_implies_0_red_dgrad_p_set)
qed
lemma GB_alt_2_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
shows "is_Groebner_basis G ⟷ (∀f ∈ pmdl G. f ≠ 0 ⟶ is_red G f)"
proof
assume "is_Groebner_basis G"
show "∀f∈pmdl G. f ≠ 0 ⟶ is_red G f"
proof (intro ballI, intro impI)
fix f
assume "f ∈ (pmdl G)" and "f ≠ 0"
show "is_red G f" by (rule GB_imp_reducibility, fact+)
qed
next
assume a2: "∀f∈pmdl G. f ≠ 0 ⟶ is_red G f"
show "is_Groebner_basis G" unfolding GB_alt_1
proof
fix f
assume "f ∈ pmdl G"
from assms show "(red G)⇧*⇧* f 0"
proof (rule is_red_implies_0_red_dgrad_p_set')
fix q
assume "q ∈ pmdl G" and "q ≠ 0"
thus "is_red G q" by (rule a2[rule_format])
qed (fact subset_refl, fact)
qed
qed
lemma GB_adds_lt:
assumes "is_Groebner_basis G" and "f ∈ pmdl G" and "f ≠ 0"
obtains g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f"
proof -
from assms(1) assms(2) have "(red G)⇧*⇧* f 0" by (rule GB_imp_zero_reducibility)
show ?thesis by (rule zero_reducibility_implies_lt_divisibility, fact+)
qed
lemma isGB_I_adds_lt:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes "⋀f. f ∈ pmdl G ⟹ f ∈ dgrad_p_set d m ⟹ f ≠ 0 ⟹ (∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)"
shows "is_Groebner_basis G"
using assms(1, 2)
proof (rule isGB_I_is_red)
fix f
assume "f ∈ pmdl G" and "f ∈ dgrad_p_set d m" and "f ≠ 0"
hence "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" by (rule assms(3))
then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by blast
thus "is_red G f" using ‹f ≠ 0› is_red_indI1 by blast
qed
lemma GB_alt_3_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
shows "is_Groebner_basis G ⟷ (∀f ∈ pmdl G. f ≠ 0 ⟶ (∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f))"
(is "?L ⟷ ?R")
proof
assume ?L
show ?R
proof (intro ballI impI)
fix f
assume "f ∈ pmdl G" and "f ≠ 0"
with ‹?L› obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by (rule GB_adds_lt)
thus "∃g∈G. g ≠ 0 ∧ lt g adds⇩t lt f" by blast
qed
next
assume ?R
show ?L unfolding GB_alt_2_dgrad_p_set[OF assms]
proof (intro ballI impI)
fix f
assume "f ∈ pmdl G" and "f ≠ 0"
with ‹?R› have "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt f)" by blast
then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by blast
thus "is_red G f" using ‹f ≠ 0› is_red_indI1 by blast
qed
qed
lemma GB_insert:
assumes "is_Groebner_basis G" and "f ∈ pmdl G"
shows "is_Groebner_basis (insert f G)"
using assms unfolding GB_alt_1
by (metis insert_subset pmdl.span_insert_idI red_rtrancl_subset subsetI)
lemma GB_subset:
assumes "is_Groebner_basis G" and "G ⊆ G'" and "pmdl G' = pmdl G"
shows "is_Groebner_basis G'"
using assms(1) unfolding GB_alt_1 using assms(2) assms(3) red_rtrancl_subset by blast
lemma (in ordered_term) GB_remove_0_stable_GB:
assumes "is_Groebner_basis G"
shows "is_Groebner_basis (G - {0})"
using assms by (simp only: is_Groebner_basis_def red_minus_singleton_zero)
lemmas is_red_implies_0_red_finite = is_red_implies_0_red_dgrad_p_set'[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas GB_implies_unique_nf_finite = GB_implies_unique_nf_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas GB_alt_2_finite = GB_alt_2_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas GB_alt_3_finite = GB_alt_3_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas pmdl_eqI_adds_lt_finite = pmdl_eqI_adds_lt_dgrad_p_set'[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
subsection ‹Alternative Characterization of Gr\"obner Bases via Representations of S-Polynomials›
definition spoly_rep :: "('a ⇒ nat) ⇒ nat ⇒ ('t ⇒⇩0 'b) set ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::field) ⇒ bool"
where "spoly_rep d m G g1 g2 ⟷ (∃q. spoly g1 g2 = (∑g∈G. q g ⊙ g) ∧
(∀g. q g ∈ punit.dgrad_p_set d m ∧
(q g ⊙ g ≠ 0 ⟶ lt (q g ⊙ g) ≺⇩t term_of_pair (lcs (lp g1) (lp g2),
component_of_term (lt g2)))))"
lemma spoly_repI:
"spoly g1 g2 = (∑g∈G. q g ⊙ g) ⟹ (⋀g. q g ∈ punit.dgrad_p_set d m) ⟹
(⋀g. q g ⊙ g ≠ 0 ⟹ lt (q g ⊙ g) ≺⇩t term_of_pair (lcs (lp g1) (lp g2),
component_of_term (lt g2))) ⟹
spoly_rep d m G g1 g2"
by (auto simp: spoly_rep_def)
lemma spoly_repI_zero:
assumes "spoly g1 g2 = 0"
shows "spoly_rep d m G g1 g2"
proof (rule spoly_repI)
show "spoly g1 g2 = (∑g∈G. 0 ⊙ g)" by (simp add: assms)
qed (simp_all add: punit.zero_in_dgrad_p_set)
lemma spoly_repE:
assumes "spoly_rep d m G g1 g2"
obtains q where "spoly g1 g2 = (∑g∈G. q g ⊙ g)" and "⋀g. q g ∈ punit.dgrad_p_set d m"
and "⋀g. q g ⊙ g ≠ 0 ⟹ lt (q g ⊙ g) ≺⇩t term_of_pair (lcs (lp g1) (lp g2),
component_of_term (lt g2))"
using assms by (auto simp: spoly_rep_def)
corollary isGB_D_spoly_rep:
assumes "dickson_grading d" and "is_Groebner_basis G" and "G ⊆ dgrad_p_set d m" and "finite G"
and "g1 ∈ G" and "g2 ∈ G" and "g1 ≠ 0" and "g2 ≠ 0"
shows "spoly_rep d m G g1 g2"
proof (cases "spoly g1 g2 = 0")
case True
thus ?thesis by (rule spoly_repI_zero)
next
case False
let ?v = "term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g1))"
let ?h = "crit_pair g1 g2"
from assms(7, 8) have eq: "spoly g1 g2 = fst ?h + (- snd ?h)" by (simp add: spoly_alt)
have "fst ?h ≺⇩p monomial 1 ?v" by (fact fst_crit_pair_below_lcs)
hence d1: "fst ?h = 0 ∨ lt (fst ?h) ≺⇩t ?v" by (simp only: ord_strict_p_monomial_iff)
have "snd ?h ≺⇩p monomial 1 ?v" by (fact snd_crit_pair_below_lcs)
hence d2: "snd ?h = 0 ∨ lt (- snd ?h) ≺⇩t ?v" by (simp only: ord_strict_p_monomial_iff lt_uminus)
note assms(1)
moreover from assms(5, 3) have "g1 ∈ dgrad_p_set d m" ..
moreover from assms(6, 3) have "g2 ∈ dgrad_p_set d m" ..
ultimately have "spoly g1 g2 ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_spoly)
from assms(5) have "g1 ∈ pmdl G" by (rule pmdl.span_base)
moreover from assms(6) have "g2 ∈ pmdl G" by (rule pmdl.span_base)
ultimately have "spoly g1 g2 ∈ pmdl G" by (rule pmdl_closed_spoly)
with assms(2) have "(red G)⇧*⇧* (spoly g1 g2) 0" by (rule GB_imp_zero_reducibility)
with assms(1, 3, 4) ‹spoly _ _ ∈ dgrad_p_set _ _› obtain q
where 1: "spoly g1 g2 = 0 + (∑g∈G. q g ⊙ g)" and 2: "⋀g. q g ∈ punit.dgrad_p_set d m"
and "⋀g. lt (q g ⊙ g) ≼⇩t lt (spoly g1 g2)" by (rule red_rtrancl_repE) blast
show ?thesis
proof (rule spoly_repI)
fix g
note ‹lt (q g ⊙ g) ≼⇩t lt (spoly g1 g2)›
also from d1 have "lt (spoly g1 g2) ≺⇩t ?v"
proof
assume "fst ?h = 0"
hence eq: "spoly g1 g2 = - snd ?h" by (simp add: eq)
also from d2 have "lt … ≺⇩t ?v"
proof
assume "snd ?h = 0"
with False show ?thesis by (simp add: eq)
qed
finally show ?thesis .
next
assume *: "lt (fst ?h) ≺⇩t ?v"
from d2 show ?thesis
proof
assume "snd ?h = 0"
with * show ?thesis by (simp add: eq)
next
assume **: "lt (- snd ?h) ≺⇩t ?v"
have "lt (spoly g1 g2) ≼⇩t ord_term_lin.max (lt (fst ?h)) (lt (- snd ?h))" unfolding eq
by (fact lt_plus_le_max)
also from * ** have "… ≺⇩t ?v" by (simp only: ord_term_lin.max_less_iff_conj)
finally show ?thesis .
qed
qed
also from False have "… = term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g2))"
by (simp add: spoly_def Let_def split: if_split_asm)
finally show "lt (q g ⊙ g) ≺⇩t term_of_pair (lcs (lp g1) (lp g2), component_of_term (lt g2))" .
qed (simp_all add: 1 2)
qed
text ‹The finiteness assumption on ‹G› in the following theorem could be dropped, but it makes the
proof a lot easier (although it is still fairly complicated).›
lemma isGB_I_spoly_rep:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m" and "finite G"
and "⋀g1 g2. g1 ∈ G ⟹ g2 ∈ G ⟹ g1 ≠ 0 ⟹ g2 ≠ 0 ⟹ spoly g1 g2 ≠ 0 ⟹ spoly_rep d m G g1 g2"
shows "is_Groebner_basis G"
proof (rule ccontr)
assume "¬ is_Groebner_basis G"
then obtain p where "p ∈ pmdl G" and p_in: "p ∈ dgrad_p_set d m" and "¬ (red G)⇧*⇧* p 0"
by (auto simp: GB_alt_1_dgrad_p_set[OF assms(1, 2)])
from ‹¬ is_Groebner_basis G› have "G ≠ {}" by (auto simp: is_Groebner_basis_empty)
obtain r where p_red: "(red G)⇧*⇧* p r" and r_irred: "¬ is_red G r"
proof -
define A where "A = {q. (red G)⇧*⇧* p q}"
from assms(1, 2) have "wfP (red G)¯¯" by (rule red_wf_dgrad_p_set)
moreover have "p ∈ A" by (simp add: A_def)
ultimately obtain r where "r ∈ A" and r_min: "⋀z. (red G)¯¯ z r ⟹ z ∉ A"
by (rule wfE_min[to_pred]) blast
show ?thesis
proof
from ‹r ∈ A› show *: "(red G)⇧*⇧* p r" by (simp add: A_def)
show "¬ is_red G r"
proof
assume "is_red G r"
then obtain z where "(red G) r z" by (rule is_redE)
hence "(red G)¯¯ z r" by simp
hence "z ∉ A" by (rule r_min)
hence "¬ (red G)⇧*⇧* p z" by (simp add: A_def)
moreover from * ‹(red G) r z› have "(red G)⇧*⇧* p z" ..
ultimately show False ..
qed
qed
qed
from assms(1, 2) p_in p_red have r_in: "r ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red_rtrancl)
from p_red ‹¬ (red G)⇧*⇧* p 0› have "r ≠ 0" by blast
from p_red have "p - r ∈ pmdl G" by (rule red_rtranclp_diff_in_pmdl)
with ‹p ∈ pmdl G› have "p - (p - r) ∈ pmdl G" by (rule pmdl.span_diff)
hence "r ∈ pmdl G" by simp
with assms(3) obtain q0 where r: "r = (∑g∈G. q0 g ⊙ g)" by (rule pmdl.span_finiteE)
from assms(3) have "finite (q0 ` G)" by (rule finite_imageI)
then obtain m0 where "q0 ` G ⊆ punit.dgrad_p_set d m0" by (rule punit.dgrad_p_set_exhaust)
define m' where "m' = ord_class.max m m0"
have "dgrad_p_set d m ⊆ dgrad_p_set d m'" by (rule dgrad_p_set_subset) (simp add: m'_def)
with assms(2) have G_sub: "G ⊆ dgrad_p_set d m'" by (rule subset_trans)
have "punit.dgrad_p_set d m0 ⊆ punit.dgrad_p_set d m'"
by (rule punit.dgrad_p_set_subset) (simp add: m'_def)
with ‹q0 ` G ⊆ _› have "q0 ` G ⊆ punit.dgrad_p_set d m'" by (rule subset_trans)
define mlt where "mlt = (λq. ord_term_lin.Max (lt ` {q g ⊙ g | g. g ∈ G ∧ q g ⊙ g ≠ 0}))"
define mnum where "mnum = (λq. card {g∈G. q g ⊙ g ≠ 0 ∧ lt (q g ⊙ g) = mlt q})"
define rel where "rel = (λq1 q2. mlt q1 ≺⇩t mlt q2 ∨ (mlt q1 = mlt q2 ∧ mnum q1 < mnum q2))"
define rel_dom where "rel_dom = {q. q ` G ⊆ punit.dgrad_p_set d m' ∧ r = (∑g∈G. q g ⊙ g)}"
have mlt_in: "mlt q ∈ lt ` {q g ⊙ g | g. g ∈ G ∧ q g ⊙ g ≠ 0}" if "q ∈ rel_dom" for q
unfolding mlt_def
proof (rule ord_term_lin.Max_in, simp_all add: assms(3), rule ccontr)
assume "∄g. g ∈ G ∧ q g ⊙ g ≠ 0"
hence "q g ⊙ g = 0" if "g ∈ G" for g using that by simp
with that have "r = 0" by (simp add: rel_dom_def)
with ‹r ≠ 0› show False ..
qed
have rel_dom_dgrad_set: "pp_of_term ` mlt ` rel_dom ⊆ dgrad_set d m'"
proof (rule subsetI, elim imageE)
fix q v t
assume "q ∈ rel_dom" and v: "v = mlt q" and t: "t = pp_of_term v"
from this(1) have "v ∈ lt ` {q g ⊙ g | g. g ∈ G ∧ q g ⊙ g ≠ 0}" unfolding v by (rule mlt_in)
then obtain g where "g ∈ G" and "q g ⊙ g ≠ 0" and v: "v = lt (q g ⊙ g)" by blast
from this(2) have "q g ≠ 0" and "g ≠ 0" by auto
hence "v = punit.lt (q g) ⊕ lt g" unfolding v by (rule lt_mult_scalar)
hence "t = punit.lt (q g) + lp g" by (simp add: t pp_of_term_splus)
also from assms(1) have "d … = ord_class.max (d (punit.lt (q g))) (d (lp g))"
by (rule dickson_gradingD1)
also have "… ≤ m'"
proof (rule max.boundedI)
from ‹g ∈ G› ‹q ∈ rel_dom› have "q g ∈ punit.dgrad_p_set d m'" by (auto simp: rel_dom_def)
moreover from ‹q g ≠ 0› have "punit.lt (q g) ∈ keys (q g)" by (rule punit.lt_in_keys)
ultimately show "d (punit.lt (q g)) ≤ m'" by (rule punit.dgrad_p_setD[simplified])
next
from ‹g ∈ G› G_sub have "g ∈ dgrad_p_set d m'" ..
moreover from ‹g ≠ 0› have "lt g ∈ keys g" by (rule lt_in_keys)
ultimately show "d (lp g) ≤ m'" by (rule dgrad_p_setD)
qed
finally show "t ∈ dgrad_set d m'" by (simp add: dgrad_set_def)
qed
obtain q where "q ∈ rel_dom" and q_min: "⋀q'. rel q' q ⟹ q' ∉ rel_dom"
proof -
from ‹q0 ` G ⊆ punit.dgrad_p_set d m'› have "q0 ∈ rel_dom" by (simp add: rel_dom_def r)
hence "mlt q0 ∈ mlt ` rel_dom" by (rule imageI)
with assms(1) obtain u where "u ∈ mlt ` rel_dom" and u_min: "⋀w. w ≺⇩t u ⟹ w ∉ mlt ` rel_dom"
using rel_dom_dgrad_set by (rule ord_term_minimum_dgrad_set) blast
from this(1) obtain q' where "q' ∈ rel_dom" and u: "u = mlt q'" ..
hence "q' ∈ rel_dom ∩ {q. mlt q = u}" (is "_ ∈ ?A") by simp
hence "mnum q' ∈ mnum ` ?A" by (rule imageI)
with wf[to_pred] obtain k where "k ∈ mnum ` ?A" and k_min: "⋀l. l < k ⟹ l ∉ mnum ` ?A"
by (rule wfE_min[to_pred]) blast
from this(1) obtain q'' where "q'' ∈ rel_dom" and mlt'': "mlt q'' = u" and k: "k = mnum q''"
by blast
from this(1) show ?thesis
proof
fix q0
assume "rel q0 q''"
show "q0 ∉ rel_dom"
proof
assume "q0 ∈ rel_dom"
from ‹rel q0 q''› show False unfolding rel_def
proof (elim disjE conjE)
assume "mlt q0 ≺⇩t mlt q''"
hence "mlt q0 ∉ mlt ` rel_dom" unfolding mlt'' by (rule u_min)
moreover from ‹q0 ∈ rel_dom› have "mlt q0 ∈ mlt ` rel_dom" by (rule imageI)
ultimately show ?thesis ..
next
assume "mlt q0 = mlt q''"
with ‹q0 ∈ rel_dom› have "q0 ∈ ?A" by (simp add: mlt'')
assume "mnum q0 < mnum q''"
hence "mnum q0 ∉ mnum ` ?A" unfolding k[symmetric] by (rule k_min)
with ‹q0 ∈ ?A› show ?thesis by blast
qed
qed
qed
qed
from this(1) have q_in: "⋀g. g ∈ G ⟹ q g ∈ punit.dgrad_p_set d m'"
and r: "r = (∑g∈G. q g ⊙ g)" by (auto simp: rel_dom_def)
define v where "v = mlt q"
from ‹q ∈ rel_dom› have "v ∈ lt ` {q g ⊙ g | g. g ∈ G ∧ q g ⊙ g ≠ 0}" unfolding v_def
by (rule mlt_in)
then obtain g1 where "g1 ∈ G" and "q g1 ⊙ g1 ≠ 0" and v1: "v = lt (q g1 ⊙ g1)" by blast
moreover define M where "M = {g∈G. q g ⊙ g ≠ 0 ∧ lt (q g ⊙ g) = v}"
ultimately have "g1 ∈ M" by simp
have v_max: "lt (q g ⊙ g) ≺⇩t v" if "g ∈ G" and "g ∉ M" and "q g ⊙ g ≠ 0" for g
proof -
from that have "lt (q g ⊙ g) ≠ v" by (auto simp: M_def)
moreover have "lt (q g ⊙ g) ≼⇩t v" unfolding v_def mlt_def
by (rule ord_term_lin.Max_ge) (auto simp: assms(3) ‹q g ⊙ g ≠ 0› intro!: imageI ‹g ∈ G›)
ultimately show ?thesis by simp
qed
from ‹q g1 ⊙ g1 ≠ 0› have "q g1 ≠ 0" and "g1 ≠ 0" by auto
hence v1': "v = punit.lt (q g1) ⊕ lt g1" unfolding v1 by (rule lt_mult_scalar)
have "M - {g1} ≠ {}"
proof
assume "M - {g1} = {}"
have "v ∈ keys (q g1 ⊙ g1)" unfolding v1 using ‹q g1 ⊙ g1 ≠ 0› by (rule lt_in_keys)
moreover have "v ∉ keys (∑g∈G-{g1}. q g ⊙ g)"
proof
assume "v ∈ keys (∑g∈G-{g1}. q g ⊙ g)"
also have "… ⊆ (⋃g∈G-{g1}. keys (q g ⊙ g))" by (fact keys_sum_subset)
finally obtain g where "g ∈ G - {g1}" and "v ∈ keys (q g ⊙ g)" ..
from this(2) have "q g ⊙ g ≠ 0" and "v ≼⇩t lt (q g ⊙ g)" by (auto intro: lt_max_keys)
from ‹g ∈ G - {g1}› ‹M - {g1} = {}› have "g ∈ G" and "g ∉ M" by blast+
hence "lt (q g ⊙ g) ≺⇩t v" by (rule v_max) fact
with ‹v ≼⇩t _› show False by simp
qed
ultimately have "v ∈ keys (q g1 ⊙ g1 + (∑g∈G-{g1}. q g ⊙ g))" by (rule in_keys_plusI1)
also from ‹g1 ∈ G› assms(3) have "… = keys r" by (simp add: r sum.remove)
finally have "v ∈ keys r" .
with ‹g1 ∈ G› ‹g1 ≠ 0› have "is_red G r" by (rule is_red_addsI) (simp add: v1' term_simps)
with r_irred show False ..
qed
then obtain g2 where "g2 ∈ M" and "g1 ≠ g2" by blast
from this(1) have "g2 ∈ G" and "q g2 ⊙ g2 ≠ 0" and v2: "v = lt (q g2 ⊙ g2)" by (simp_all add: M_def)
from this(2) have "q g2 ≠ 0" and "g2 ≠ 0" by auto
hence v2': "v = punit.lt (q g2) ⊕ lt g2" unfolding v2 by (rule lt_mult_scalar)
hence "component_of_term (punit.lt (q g1) ⊕ lt g1) = component_of_term (punit.lt (q g2) ⊕ lt g2)"
by (simp only: v1' flip: v2')
hence cmp_eq: "component_of_term (lt g1) = component_of_term (lt g2)" by (simp add: term_simps)
have "M ⊆ G" by (simp add: M_def)
have "r = q g1 ⊙ g1 + (∑g∈G - {g1}. q g ⊙ g)"
using assms(3) ‹g1 ∈ G› by (simp add: r sum.remove)
also have "… = q g1 ⊙ g1 + q g2 ⊙ g2 + (∑g∈G - {g1} - {g2}. q g ⊙ g)"
using assms(3) ‹g2 ∈ G› ‹g1 ≠ g2›
by (metis (no_types, lifting) add.assoc finite_Diff insert_Diff insert_Diff_single insert_iff
sum.insert_remove)
finally have r: "r = q g1 ⊙ g1 + q g2 ⊙ g2 + (∑g∈G - {g1, g2}. q g ⊙ g)"
by (simp flip: Diff_insert2)
let ?l = "lcs (lp g1) (lp g2)"
let ?v = "term_of_pair (?l, component_of_term (lt g2))"
have "lp g1 adds lp (q g1 ⊙ g1)" by (simp add: v1' pp_of_term_splus flip: v1)
moreover have "lp g2 adds lp (q g1 ⊙ g1)" by (simp add: v2' pp_of_term_splus flip: v1)
ultimately have l_adds: "?l adds lp (q g1 ⊙ g1)" by (rule lcs_adds)
have "spoly_rep d m G g1 g2"
proof (cases "spoly g1 g2 = 0")
case True
thus ?thesis by (rule spoly_repI_zero)
next
case False
with ‹g1 ∈ G› ‹g2 ∈ G› ‹g1 ≠ 0› ‹g2 ≠ 0› show ?thesis by (rule assms(4))
qed
then obtain q' where spoly: "spoly g1 g2 = (∑g∈G. q' g ⊙ g)"
and "⋀g. q' g ∈ punit.dgrad_p_set d m" and "⋀g. q' g ⊙ g ≠ 0 ⟹ lt (q' g ⊙ g) ≺⇩t ?v"
by (rule spoly_repE) blast
note this(2)
also have "punit.dgrad_p_set d m ⊆ punit.dgrad_p_set d m'"
by (rule punit.dgrad_p_set_subset) (simp add: m'_def)
finally have q'_in: "⋀g. q' g ∈ punit.dgrad_p_set d m'" .
define mu where "mu = monomial (lc (q g1 ⊙ g1)) (lp (q g1 ⊙ g1) - ?l)"
define mu1 where "mu1 = monomial (1 / lc g1) (?l - lp g1)"
define mu2 where "mu2 = monomial (1 / lc g2) (?l - lp g2)"
define q'' where "q'' = (λg. q g + mu * q' g)
(g1:=punit.tail (q g1) + mu * q' g1, g2:=q g2 + mu * q' g2 + mu * mu2)"
from ‹q g1 ⊙ g1 ≠ 0› have "mu ≠ 0" by (simp add: mu_def monomial_0_iff lc_eq_zero_iff)
from ‹g1 ≠ 0› l_adds have mu_times_mu1: "mu * mu1 = monomial (punit.lc (q g1)) (punit.lt (q g1))"
by (simp add: mu_def mu1_def times_monomial_monomial lc_mult_scalar lc_eq_zero_iff
minus_plus_minus_cancel adds_lcs v1' pp_of_term_splus flip: v1)
from l_adds have mu_times_mu2: "mu * mu2 = monomial (lc (q g1 ⊙ g1) / lc g2) (punit.lt (q g2))"
by (simp add: mu_def mu2_def times_monomial_monomial lc_mult_scalar minus_plus_minus_cancel
adds_lcs_2 v2' pp_of_term_splus flip: v1)
have "mu1 ⊙ g1 - mu2 ⊙ g2 = spoly g1 g2"
by (simp add: spoly_def Let_def cmp_eq lc_def mult_scalar_monomial mu1_def mu2_def)
also have "… = q' g1 ⊙ g1 + (∑g∈G - {g1}. q' g ⊙ g)"
using assms(3) ‹g1 ∈ G› by (simp add: spoly sum.remove)
also have "… = q' g1 ⊙ g1 + q' g2 ⊙ g2 + (∑g∈G - {g1} - {g2}. q' g ⊙ g)"
using assms(3) ‹g2 ∈ G› ‹g1 ≠ g2›
by (metis (no_types, lifting) add.assoc finite_Diff insert_Diff insert_Diff_single insert_iff
sum.insert_remove)
finally have "(q' g1 - mu1) ⊙ g1 + (q' g2 + mu2) ⊙ g2 + (∑g∈G - {g1, g2}. q' g ⊙ g) = 0"
by (simp add: algebra_simps flip: Diff_insert2)
hence "0 = mu ⊙ ((q' g1 - mu1) ⊙ g1 + (q' g2 + mu2) ⊙ g2 + (∑g∈G - {g1, g2}. q' g ⊙ g))" by simp
also have "… = (mu * q' g1 - mu * mu1) ⊙ g1 + (mu * q' g2 + mu * mu2) ⊙ g2 +
(∑g∈G - {g1, g2}. (mu * q' g) ⊙ g)"
by (simp add: mult_scalar_distrib_left sum_mult_scalar_distrib_left distrib_left right_diff_distrib
flip: mult_scalar_assoc)
finally have "r = r + (mu * q' g1 - mu * mu1) ⊙ g1 + (mu * q' g2 + mu * mu2) ⊙ g2 +
(∑g∈G - {g1, g2}. (mu * q' g) ⊙ g)" by simp
also have "… = (q g1 - mu * mu1 + mu * q' g1) ⊙ g1 + (q g2 + mu * q' g2 + mu * mu2) ⊙ g2 +
(∑g∈G - {g1, g2}. (q g + mu * q' g) ⊙ g)"
by (simp add: r algebra_simps flip: sum.distrib)
also have "q g1 - mu * mu1 = punit.tail (q g1)"
by (simp only: mu_times_mu1 punit.leading_monomial_tail diff_eq_eq add.commute[of "punit.tail (q g1)"])
finally have "r = q'' g1 ⊙ g1 + q'' g2 ⊙ g2 + (∑g∈G - {g1} - {g2}. q'' g ⊙ g)"
using ‹g1 ≠ g2› by (simp add: q''_def flip: Diff_insert2)
also from ‹finite G› ‹g1 ≠ g2› ‹g1 ∈ G› ‹g2 ∈ G› have "… = (∑g∈G. q'' g ⊙ g)"
by (simp add: sum.remove) (metis (no_types, lifting) finite_Diff insert_Diff insert_iff sum.remove)
finally have r: "r = (∑g∈G. q'' g ⊙ g)" .
have 1: "lt ((mu * q' g) ⊙ g) ≺⇩t v" if "(mu * q' g) ⊙ g ≠ 0" for g
proof -
from that have "q' g ⊙ g ≠ 0" by (auto simp: mult_scalar_assoc)
hence *: "lt (q' g ⊙ g) ≺⇩t ?v" by fact
from ‹q' g ⊙ g ≠ 0› ‹mu ≠ 0› have "lt ((mu * q' g) ⊙ g) = (lp (q g1 ⊙ g1) - ?l) ⊕ lt (q' g ⊙ g)"
by (simp add: mult_scalar_assoc lt_mult_scalar) (simp add: mu_def punit.lt_monomial monomial_0_iff)
also from * have "… ≺⇩t (lp (q g1 ⊙ g1) - ?l) ⊕ ?v" by (rule splus_mono_strict)
also from l_adds have "… = v" by (simp add: splus_def minus_plus term_simps v1' flip: cmp_eq v1)
finally show ?thesis .
qed
have 2: "lt (q'' g1 ⊙ g1) ≺⇩t v" if "q'' g1 ⊙ g1 ≠ 0" using that
proof (rule lt_less)
fix u
assume "v ≼⇩t u"
have "u ∉ keys (q'' g1 ⊙ g1)"
proof
assume "u ∈ keys (q'' g1 ⊙ g1)"
also from ‹g1 ≠ g2› have "… = keys ((punit.tail (q g1) + mu * q' g1) ⊙ g1)"
by (simp add: q''_def)
also have "… ⊆ keys (punit.tail (q g1) ⊙ g1) ∪ keys ((mu * q' g1) ⊙ g1)"
unfolding mult_scalar_distrib_right by (fact Poly_Mapping.keys_add)
finally show False
proof
assume "u ∈ keys (punit.tail (q g1) ⊙ g1)"
hence "u ≼⇩t lt (punit.tail (q g1) ⊙ g1)" by (rule lt_max_keys)
also have "… ≼⇩t punit.lt (punit.tail (q g1)) ⊕ lt g1"
by (metis in_keys_mult_scalar_le lt_def lt_in_keys min_term_min)
also have "… ≺⇩t punit.lt (q g1) ⊕ lt g1"
proof (intro splus_mono_strict_left punit.lt_tail notI)
assume "punit.tail (q g1) = 0"
with ‹u ∈ keys (punit.tail (q g1) ⊙ g1)› show False by simp
qed
also have "… = v" by (simp only: v1')
finally show ?thesis using ‹v ≼⇩t u› by simp
next
assume "u ∈ keys ((mu * q' g1) ⊙ g1)"
hence "(mu * q' g1) ⊙ g1 ≠ 0" and "u ≼⇩t lt ((mu * q' g1) ⊙ g1)" by (auto intro: lt_max_keys)
note this(2)
also from ‹(mu * q' g1) ⊙ g1 ≠ 0› have "lt ((mu * q' g1) ⊙ g1) ≺⇩t v" by (rule 1)
finally show ?thesis using ‹v ≼⇩t u› by simp
qed
qed
thus "lookup (q'' g1 ⊙ g1) u = 0" by (simp add: in_keys_iff)
qed
have 3: "lt (q'' g2 ⊙ g2) ≼⇩t v"
proof (rule lt_le)
fix u
assume "v ≺⇩t u"
have "u ∉ keys (q'' g2 ⊙ g2)"
proof
assume "u ∈ keys (q'' g2 ⊙ g2)"
also have "… = keys ((q g2 + mu * q' g2 + mu * mu2) ⊙ g2)" by (simp add: q''_def)
also have "… ⊆ keys (q g2 ⊙ g2 + (mu * q' g2) ⊙ g2) ∪ keys ((mu * mu2) ⊙ g2)"
unfolding mult_scalar_distrib_right by (fact Poly_Mapping.keys_add)
finally show False
proof
assume "u ∈ keys (q g2 ⊙ g2 + (mu * q' g2) ⊙ g2)"
also have "… ⊆ keys (q g2 ⊙ g2) ∪ keys ((mu * q' g2) ⊙ g2)" by (fact Poly_Mapping.keys_add)
finally show ?thesis
proof
assume "u ∈ keys (q g2 ⊙ g2)"
hence "u ≼⇩t lt (q g2 ⊙ g2)" by (rule lt_max_keys)
with ‹v ≺⇩t u› show ?thesis by (simp add: v2)
next
assume "u ∈ keys ((mu * q' g2) ⊙ g2)"
hence "(mu * q' g2) ⊙ g2 ≠ 0" and "u ≼⇩t lt ((mu * q' g2) ⊙ g2)" by (auto intro: lt_max_keys)
note this(2)
also from ‹(mu * q' g2) ⊙ g2 ≠ 0› have "lt ((mu * q' g2) ⊙ g2) ≺⇩t v" by (rule 1)
finally show ?thesis using ‹v ≺⇩t u› by simp
qed
next
assume "u ∈ keys ((mu * mu2) ⊙ g2)"
hence "(mu * mu2) ⊙ g2 ≠ 0" and "u ≼⇩t lt ((mu * mu2) ⊙ g2)" by (auto intro: lt_max_keys)
from this(1) have "(mu * mu2) ≠ 0" by auto
note ‹u ≼⇩t _›
also from ‹mu * mu2 ≠ 0› ‹g2 ≠ 0› have "lt ((mu * mu2) ⊙ g2) = punit.lt (q g2) ⊕ lt g2"
by (simp add: lt_mult_scalar) (simp add: mu_times_mu2 punit.lt_monomial monomial_0_iff)
finally show ?thesis using ‹v ≺⇩t u› by (simp add: v2')
qed
qed
thus "lookup (q'' g2 ⊙ g2) u = 0" by (simp add: in_keys_iff)
qed
have 4: "lt (q'' g ⊙ g) ≼⇩t v" if "g ∈ M" for g
proof (cases "g ∈ {g1, g2}")
case True
hence "g = g1 ∨ g = g2" by simp
thus ?thesis
proof
assume "g = g1"
show ?thesis
proof (cases "q'' g1 ⊙ g1 = 0")
case True
thus ?thesis by (simp add: ‹g = g1› min_term_min)
next
case False
hence "lt (q'' g ⊙ g) ≺⇩t v" unfolding ‹g = g1› by (rule 2)
thus ?thesis by simp
qed
next
assume "g = g2"
with 3 show ?thesis by simp
qed
next
case False
hence q'': "q'' g = q g + mu * q' g" by (simp add: q''_def)
show ?thesis
proof (rule lt_le)
fix u
assume "v ≺⇩t u"
have "u ∉ keys (q'' g ⊙ g)"
proof
assume "u ∈ keys (q'' g ⊙ g)"
also have "… ⊆ keys (q g ⊙ g) ∪ keys ((mu * q' g) ⊙ g)"
unfolding q'' mult_scalar_distrib_right by (fact Poly_Mapping.keys_add)
finally show False
proof
assume "u ∈ keys (q g ⊙ g)"
hence "u ≼⇩t lt (q g ⊙ g)" by (rule lt_max_keys)
with ‹g ∈ M› ‹v ≺⇩t u› show ?thesis by (simp add: M_def)
next
assume "u ∈ keys ((mu * q' g) ⊙ g)"
hence "(mu * q' g) ⊙ g ≠ 0" and "u ≼⇩t lt ((mu * q' g) ⊙ g)" by (auto intro: lt_max_keys)
note this(2)
also from ‹(mu * q' g) ⊙ g ≠ 0› have "lt ((mu * q' g) ⊙ g) ≺⇩t v" by (rule 1)
finally show ?thesis using ‹v ≺⇩t u› by simp
qed
qed
thus "lookup (q'' g ⊙ g) u = 0" by (simp add: in_keys_iff)
qed
qed
have 5: "lt (q'' g ⊙ g) ≺⇩t v" if "g ∈ G" and "g ∉ M" and "q'' g ⊙ g ≠ 0" for g using that(3)
proof (rule lt_less)
fix u
assume "v ≼⇩t u"
from that(2) ‹g1 ∈ M› ‹g2 ∈ M› have "g ≠ g1" and "g ≠ g2" by blast+
hence q'': "q'' g = q g + mu * q' g" by (simp add: q''_def)
have "u ∉ keys (q'' g ⊙ g)"
proof
assume "u ∈ keys (q'' g ⊙ g)"
also have "… ⊆ keys (q g ⊙ g) ∪ keys ((mu * q' g) ⊙ g)"
unfolding q'' mult_scalar_distrib_right by (fact Poly_Mapping.keys_add)
finally show False
proof
assume "u ∈ keys (q g ⊙ g)"
hence "q g ⊙ g ≠ 0" and "u ≼⇩t lt (q g ⊙ g)" by (auto intro: lt_max_keys)
note this(2)
also from that(1, 2) ‹q g ⊙ g ≠ 0› have "… ≺⇩t v" by (rule v_max)
finally show ?thesis using ‹v ≼⇩t u› by simp
next
assume "u ∈ keys ((mu * q' g) ⊙ g)"
hence "(mu * q' g) ⊙ g ≠ 0" and "u ≼⇩t lt ((mu * q' g) ⊙ g)" by (auto intro: lt_max_keys)
note this(2)
also from ‹(mu * q' g) ⊙ g ≠ 0› have "lt ((mu * q' g) ⊙ g) ≺⇩t v" by (rule 1)
finally show ?thesis using ‹v ≼⇩t u› by simp
qed
qed
thus "lookup (q'' g ⊙ g) u = 0" by (simp add: in_keys_iff)
qed
define u where "u = mlt q''"
have u_in: "u ∈ lt ` {q'' g ⊙ g | g. g ∈ G ∧ q'' g ⊙ g ≠ 0}" unfolding u_def mlt_def
proof (rule ord_term_lin.Max_in, simp_all add: assms(3), rule ccontr)
assume "∄g. g ∈ G ∧ q'' g ⊙ g ≠ 0"
hence "q'' g ⊙ g = 0" if "g ∈ G" for g using that by simp
hence "r = 0" by (simp add: r)
with ‹r ≠ 0› show False ..
qed
have u_max: "lt (q'' g ⊙ g) ≼⇩t u" if "g ∈ G" for g
proof (cases "q'' g ⊙ g = 0")
case True
thus ?thesis by (simp add: min_term_min)
next
case False
show ?thesis unfolding u_def mlt_def
by (rule ord_term_lin.Max_ge) (auto simp: assms(3) False intro!: imageI ‹g ∈ G›)
qed
have "q'' ∈ rel_dom"
proof (simp add: rel_dom_def r, intro subsetI, elim imageE)
fix g
assume "g ∈ G"
from assms(1) l_adds have "d (lp (q g1 ⊙ g1) - ?l) ≤ d (lp (q g1 ⊙ g1))"
by (rule dickson_grading_minus)
also have "… = d (punit.lt (q g1) + lp g1)" by (simp add: v1' term_simps flip: v1)
also from assms(1) have "… = ord_class.max (d (punit.lt (q g1))) (d (lp g1))"
by (rule dickson_gradingD1)
also have "… ≤ m'"
proof (rule max.boundedI)
from ‹g1 ∈ G› have "q g1 ∈ punit.dgrad_p_set d m'" by (rule q_in)
moreover from ‹q g1 ≠ 0› have "punit.lt (q g1) ∈ keys (q g1)" by (rule punit.lt_in_keys)
ultimately show "d (punit.lt (q g1)) ≤ m'" by (rule punit.dgrad_p_setD[simplified])
next
from ‹g1 ∈ G› G_sub have "g1 ∈ dgrad_p_set d m'" ..
moreover from ‹g1 ≠ 0› have "lt g1 ∈ keys g1" by (rule lt_in_keys)
ultimately show "d (lp g1) ≤ m'" by (rule dgrad_p_setD)
qed
finally have d1: "d (lp (q g1 ⊙ g1) - ?l) ≤ m'" .
have "d (?l - lp g2) ≤ ord_class.max (d (lp g2)) (d (lp g1))"
unfolding lcs_comm[of "lp g1"] using assms(1) by (rule dickson_grading_lcs_minus)
also have "… ≤ m'"
proof (rule max.boundedI)
from ‹g2 ∈ G› G_sub have "g2 ∈ dgrad_p_set d m'" ..
moreover from ‹g2 ≠ 0› have "lt g2 ∈ keys g2" by (rule lt_in_keys)
ultimately show "d (lp g2) ≤ m'" by (rule dgrad_p_setD)
next
from ‹g1 ∈ G› G_sub have "g1 ∈ dgrad_p_set d m'" ..
moreover from ‹g1 ≠ 0› have "lt g1 ∈ keys g1" by (rule lt_in_keys)
ultimately show "d (lp g1) ≤ m'" by (rule dgrad_p_setD)
qed
finally have mu2: "mu2 ∈ punit.dgrad_p_set d m'"
by (simp add: mu2_def punit.dgrad_p_set_def dgrad_set_def)
fix z
assume z: "z = q'' g"
have "g = g1 ∨ g = g2 ∨ (g ≠ g1 ∧ g ≠ g2)" by blast
thus "z ∈ punit.dgrad_p_set d m'"
proof (elim disjE conjE)
assume "g = g1"
with ‹g1 ≠ g2› have "q'' g = punit.tail (q g1) + mu * q' g1" by (simp add: q''_def)
also have "… ∈ punit.dgrad_p_set d m'" unfolding mu_def times_monomial_left
by (intro punit.dgrad_p_set_closed_plus punit.dgrad_p_set_closed_tail
punit.dgrad_p_set_closed_monom_mult d1 assms(1) q_in q'_in ‹g1 ∈ G›)
finally show ?thesis by (simp only: z)
next
assume "g = g2"
hence "q'' g = q g2 + mu * q' g2 + mu * mu2" by (simp add: q''_def)
also have "… ∈ punit.dgrad_p_set d m'" unfolding mu_def times_monomial_left
by (intro punit.dgrad_p_set_closed_plus punit.dgrad_p_set_closed_monom_mult
d1 mu2 q_in q'_in assms(1) ‹g2 ∈ G›)
finally show ?thesis by (simp only: z)
next
assume "g ≠ g1" and "g ≠ g2"
hence "q'' g = q g + mu * q' g" by (simp add: q''_def)
also have "… ∈ punit.dgrad_p_set d m'" unfolding mu_def times_monomial_left
by (intro punit.dgrad_p_set_closed_plus punit.dgrad_p_set_closed_monom_mult
d1 assms(1) q_in q'_in ‹g ∈ G›)
finally show ?thesis by (simp only: z)
qed
qed
with q_min have "¬ rel q'' q" by blast
hence "v ≼⇩t u" and "u ≠ v ∨ mnum q ≤ mnum q''" by (auto simp: v_def u_def rel_def)
moreover have "u ≼⇩t v"
proof -
from u_in obtain g where "g ∈ G" and "q'' g ⊙ g ≠ 0" and u: "u = lt (q'' g ⊙ g)" by blast
show ?thesis
proof (cases "g ∈ M")
case True
thus ?thesis unfolding u by (rule 4)
next
case False
with ‹g ∈ G› have "lt (q'' g ⊙ g) ≺⇩t v" using ‹q'' g ⊙ g ≠ 0› by (rule 5)
thus ?thesis by (simp add: u)
qed
qed
ultimately have u_v: "u = v" and "mnum q ≤ mnum q''" by simp_all
note this(2)
also have "mnum q'' < card M" unfolding mnum_def
proof (rule psubset_card_mono)
from ‹M ⊆ G› ‹finite G› show "finite M" by (rule finite_subset)
next
have "{g∈G. q'' g ⊙ g ≠ 0 ∧ lt (q'' g ⊙ g) = v} ⊆ M - {g1}"
proof
fix g
assume "g ∈ {g∈G. q'' g ⊙ g ≠ 0 ∧ lt (q'' g ⊙ g) = v}"
hence "g ∈ G" and "q'' g ⊙ g ≠ 0" and "lt (q'' g ⊙ g) = v" by simp_all
with 2 5 show "g ∈ M - {g1}" by blast
qed
also from ‹g1 ∈ M› have "… ⊂ M" by blast
finally show "{g∈G. q'' g ⊙ g ≠ 0 ∧ lt (q'' g ⊙ g) = mlt q''} ⊂ M"
by (simp only: u_v flip: u_def)
qed
also have "… = mnum q" by (simp only: M_def mnum_def v_def)
finally show False ..
qed
subsection ‹Replacing Elements in Gr\"obner Bases›
lemma replace_in_dgrad_p_set:
assumes "G ⊆ dgrad_p_set d m"
obtains n where "q ∈ dgrad_p_set d n" and "G ⊆ dgrad_p_set d n"
and "insert q (G - {p}) ⊆ dgrad_p_set d n"
proof -
from assms obtain n where "m ≤ n" and 1: "q ∈ dgrad_p_set d n" and 2: "G ⊆ dgrad_p_set d n"
by (rule dgrad_p_set_insert)
from this(2, 3) have "insert q (G - {p}) ⊆ dgrad_p_set d n" by auto
with 1 2 show ?thesis ..
qed
lemma GB_replace_lt_adds_stable_GB_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes isGB: "is_Groebner_basis G" and "q ≠ 0" and q: "q ∈ (pmdl G)" and "lt q adds⇩t lt p"
shows "is_Groebner_basis (insert q (G - {p}))" (is "is_Groebner_basis ?G'")
proof -
from assms(2) obtain n where 1: "G ⊆ dgrad_p_set d n" and 2: "?G' ⊆ dgrad_p_set d n"
by (rule replace_in_dgrad_p_set)
from isGB show ?thesis unfolding GB_alt_3_dgrad_p_set[OF assms(1) 1] GB_alt_3_dgrad_p_set[OF assms(1) 2]
proof (intro ballI impI)
fix f
assume f1: "f ∈ (pmdl ?G')" and "f ≠ 0"
and a1: "∀f∈pmdl G. f ≠ 0 ⟶ (∃g∈G. g ≠ 0 ∧ lt g adds⇩t lt f)"
from f1 pmdl.replace_span[OF q, of p] have "f ∈ pmdl G" ..
from a1[rule_format, OF this ‹f ≠ 0›] obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f" by auto
show "∃g∈?G'. g ≠ 0 ∧ lt g adds⇩t lt f"
proof (cases "g = p")
case True
show ?thesis
proof
from ‹lt q adds⇩t lt p› have "lt q adds⇩t lt g" unfolding True .
also have "... adds⇩t lt f" by fact
finally have "lt q adds⇩t lt f" .
with ‹q ≠ 0› show "q ≠ 0 ∧ lt q adds⇩t lt f" ..
next
show "q ∈ ?G'" by simp
qed
next
case False
show ?thesis
proof
show "g ≠ 0 ∧ lt g adds⇩t lt f" by (rule, fact+)
next
from ‹g ∈ G› False show "g ∈ ?G'" by blast
qed
qed
qed
qed
lemma GB_replace_lt_adds_stable_pmdl_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes isGB: "is_Groebner_basis G" and "q ≠ 0" and "q ∈ pmdl G" and "lt q adds⇩t lt p"
shows "pmdl (insert q (G - {p})) = pmdl G" (is "pmdl ?G' = pmdl G")
proof (rule, rule pmdl.replace_span, fact, rule)
fix f
assume "f ∈ pmdl G"
note assms(1)
moreover from assms(2) obtain n where "?G' ⊆ dgrad_p_set d n" by (rule replace_in_dgrad_p_set)
moreover have "is_Groebner_basis ?G'" by (rule GB_replace_lt_adds_stable_GB_dgrad_p_set, fact+)
ultimately have "∃! h. (red ?G')⇧*⇧* f h ∧ ¬ is_red ?G' h" by (rule GB_implies_unique_nf_dgrad_p_set)
then obtain h where ftoh: "(red ?G')⇧*⇧* f h" and irredh: "¬ is_red ?G' h" by auto
have "¬ is_red G h"
proof
assume "is_red G h"
have "is_red ?G' h" by (rule replace_lt_adds_stable_is_red, fact+)
with irredh show False ..
qed
have "f - h ∈ pmdl ?G'" by (rule red_rtranclp_diff_in_pmdl, rule ftoh)
have "f - h ∈ pmdl G" by (rule, fact, rule pmdl.replace_span, fact)
from pmdl.span_diff[OF this ‹f ∈ pmdl G›] have "-h ∈ pmdl G" by simp
from pmdl.span_neg[OF this] have "h ∈ pmdl G" by simp
with isGB ‹¬ is_red G h› have "h = 0" using GB_imp_reducibility by auto
with ftoh have "(red ?G')⇧*⇧* f 0" by simp
thus "f ∈ pmdl ?G'" by (simp add: red_rtranclp_0_in_pmdl)
qed
lemma GB_replace_red_stable_GB_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes isGB: "is_Groebner_basis G" and "p ∈ G" and q: "red (G - {p}) p q"
shows "is_Groebner_basis (insert q (G - {p}))" (is "is_Groebner_basis ?G'")
proof -
from assms(2) obtain n where 1: "G ⊆ dgrad_p_set d n" and 2: "?G' ⊆ dgrad_p_set d n"
by (rule replace_in_dgrad_p_set)
from isGB show ?thesis unfolding GB_alt_2_dgrad_p_set[OF assms(1) 1] GB_alt_2_dgrad_p_set[OF assms(1) 2]
proof (intro ballI impI)
fix f
assume f1: "f ∈ (pmdl ?G')" and "f ≠ 0"
and a1: "∀f∈pmdl G. f ≠ 0 ⟶ is_red G f"
have "q ∈ pmdl G"
proof (rule pmdl_closed_red, rule pmdl.span_mono)
from pmdl.span_superset ‹p ∈ G› show "p ∈ pmdl G" ..
next
show "G - {p} ⊆ G" by (rule Diff_subset)
qed (rule q)
from f1 pmdl.replace_span[OF this, of p] have "f ∈ pmdl G" ..
have "is_red G f" by (rule a1[rule_format], fact+)
show "is_red ?G' f" by (rule replace_red_stable_is_red, fact+)
qed
qed
lemma GB_replace_red_stable_pmdl_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes isGB: "is_Groebner_basis G" and "p ∈ G" and ptoq: "red (G - {p}) p q"
shows "pmdl (insert q (G - {p})) = pmdl G" (is "pmdl ?G' = _")
proof -
from ‹p ∈ G› pmdl.span_superset have "p ∈ pmdl G" ..
have "q ∈ pmdl G"
by (rule pmdl_closed_red, rule pmdl.span_mono, rule Diff_subset, rule ‹p ∈ pmdl G›, rule ptoq)
show ?thesis
proof (rule, rule pmdl.replace_span, fact, rule)
fix f
assume "f ∈ pmdl G"
note assms(1)
moreover from assms(2) obtain n where "?G' ⊆ dgrad_p_set d n" by (rule replace_in_dgrad_p_set)
moreover have "is_Groebner_basis ?G'" by (rule GB_replace_red_stable_GB_dgrad_p_set, fact+)
ultimately have "∃! h. (red ?G')⇧*⇧* f h ∧ ¬ is_red ?G' h" by (rule GB_implies_unique_nf_dgrad_p_set)
then obtain h where ftoh: "(red ?G')⇧*⇧* f h" and irredh: "¬ is_red ?G' h" by auto
have "¬ is_red G h"
proof
assume "is_red G h"
have "is_red ?G' h" by (rule replace_red_stable_is_red, fact+)
with irredh show False ..
qed
have "f - h ∈ pmdl ?G'" by (rule red_rtranclp_diff_in_pmdl, rule ftoh)
have "f - h ∈ pmdl G" by (rule, fact, rule pmdl.replace_span, fact)
from pmdl.span_diff[OF this ‹f ∈ pmdl G›] have "-h ∈ pmdl G" by simp
from pmdl.span_neg[OF this] have "h ∈ pmdl G" by simp
with isGB ‹¬ is_red G h› have "h = 0" using GB_imp_reducibility by auto
with ftoh have "(red ?G')⇧*⇧* f 0" by simp
thus "f ∈ pmdl ?G'" by (simp add: red_rtranclp_0_in_pmdl)
qed
qed
lemma GB_replace_red_rtranclp_stable_GB_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes isGB: "is_Groebner_basis G" and "p ∈ G" and ptoq: "(red (G - {p}))⇧*⇧* p q"
shows "is_Groebner_basis (insert q (G - {p}))"
using ptoq
proof (induct q rule: rtranclp_induct)
case base
from isGB ‹p ∈ G› show ?case by (simp add: insert_absorb)
next
case (step y z)
show ?case
proof (cases "y = p")
case True
from assms(1) assms(2) isGB ‹p ∈ G› show ?thesis
proof (rule GB_replace_red_stable_GB_dgrad_p_set)
from ‹red (G - {p}) y z› show "red (G - {p}) p z" unfolding True .
qed
next
case False
show ?thesis
proof (cases "y ∈ G")
case True
with ‹y ≠ p› have "y ∈ G - {p}" (is "_ ∈ ?G'") by blast
hence "insert y (G - {p}) = ?G'" by auto
with step(3) have "is_Groebner_basis ?G'" by simp
from ‹y ∈ ?G'› pmdl.span_superset have "y ∈ pmdl ?G'" ..
have "z ∈ pmdl ?G'" by (rule pmdl_closed_red, rule subset_refl, fact+)
show "is_Groebner_basis (insert z ?G')" by (rule GB_insert, fact+)
next
case False
from assms(2) obtain n where "insert y (G - {p}) ⊆ dgrad_p_set d n"
by (rule replace_in_dgrad_p_set)
from assms(1) this step(3) have "is_Groebner_basis (insert z (insert y (G - {p}) - {y}))"
proof (rule GB_replace_red_stable_GB_dgrad_p_set)
from ‹red (G - {p}) y z› False show "red ((insert y (G - {p})) - {y}) y z" by simp
qed simp
moreover from False have "... = (insert z (G - {p}))" by simp
ultimately show ?thesis by simp
qed
qed
qed
lemma GB_replace_red_rtranclp_stable_pmdl_dgrad_p_set:
assumes "dickson_grading d" and "G ⊆ dgrad_p_set d m"
assumes isGB: "is_Groebner_basis G" and "p ∈ G" and ptoq: "(red (G - {p}))⇧*⇧* p q"
shows "pmdl (insert q (G - {p})) = pmdl G"
using ptoq
proof (induct q rule: rtranclp_induct)
case base
from ‹p ∈ G› show ?case by (simp add: insert_absorb)
next
case (step y z)
show ?case
proof (cases "y = p")
case True
from assms(1) assms(2) isGB ‹p ∈ G› step(2) show ?thesis unfolding True
by (rule GB_replace_red_stable_pmdl_dgrad_p_set)
next
case False
have gb: "is_Groebner_basis (insert y (G - {p}))"
by (rule GB_replace_red_rtranclp_stable_GB_dgrad_p_set, fact+)
show ?thesis
proof (cases "y ∈ G")
case True
with ‹y ≠ p› have "y ∈ G - {p}" (is "_ ∈ ?G'") by blast
hence eq: "insert y ?G' = ?G'" by auto
from ‹y ∈ ?G'› have "y ∈ pmdl ?G'" by (rule pmdl.span_base)
have "z ∈ pmdl ?G'" by (rule pmdl_closed_red, rule subset_refl, fact+)
hence "pmdl (insert z ?G') = pmdl ?G'" by (rule pmdl.span_insert_idI)
also from step(3) have "... = pmdl G" by (simp only: eq)
finally show ?thesis .
next
case False
from assms(2) obtain n where 1: "insert y (G - {p}) ⊆ dgrad_p_set d n"
by (rule replace_in_dgrad_p_set)
from False have "pmdl (insert z (G - {p})) = pmdl (insert z (insert y (G - {p}) - {y}))"
by auto
also from assms(1) 1 gb have "... = pmdl (insert y (G - {p}))"
proof (rule GB_replace_red_stable_pmdl_dgrad_p_set)
from step(2) False show "red ((insert y (G - {p})) - {y}) y z" by simp
qed simp
also have "... = pmdl G" by fact
finally show ?thesis .
qed
qed
qed
lemmas GB_replace_lt_adds_stable_GB_finite =
GB_replace_lt_adds_stable_GB_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas GB_replace_lt_adds_stable_pmdl_finite =
GB_replace_lt_adds_stable_pmdl_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas GB_replace_red_stable_GB_finite =
GB_replace_red_stable_GB_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas GB_replace_red_stable_pmdl_finite =
GB_replace_red_stable_pmdl_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas GB_replace_red_rtranclp_stable_GB_finite =
GB_replace_red_rtranclp_stable_GB_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
lemmas GB_replace_red_rtranclp_stable_pmdl_finite =
GB_replace_red_rtranclp_stable_pmdl_dgrad_p_set[OF dickson_grading_dgrad_dummy dgrad_p_set_exhaust_expl]
subsection ‹An Inconstructive Proof of the Existence of Finite Gr\"obner Bases›
lemma ex_finite_GB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
obtains G where "G ⊆ dgrad_p_set d m" and "finite G" and "is_Groebner_basis G" and "pmdl G = pmdl F"
proof -
define S where "S = {lt f | f. f ∈ pmdl F ∧ f ∈ dgrad_p_set d m ∧ f ≠ 0}"
note assms(1)
moreover from _ assms(2) have "finite (component_of_term ` S)"
proof (rule finite_subset)
have "component_of_term ` S ⊆ component_of_term ` Keys (pmdl F)"
by (rule image_mono, rule, auto simp add: S_def intro!: in_KeysI lt_in_keys)
thus "component_of_term ` S ⊆ component_of_term ` Keys F" by (simp only: components_pmdl)
qed
moreover have "pp_of_term ` S ⊆ dgrad_set d m"
proof
fix s
assume "s ∈ pp_of_term ` S"
then obtain u where "u ∈ S" and "s = pp_of_term u" ..
from this(1) obtain f where "f ∈ pmdl F ∧ f ∈ dgrad_p_set d m ∧ f ≠ 0" and u: "u = lt f"
unfolding S_def by blast
from this(1) have "f ∈ dgrad_p_set d m" and "f ≠ 0" by simp_all
have "u ∈ keys f" unfolding u by (rule lt_in_keys, fact)
with ‹f ∈ dgrad_p_set d m› have "d (pp_of_term u) ≤ m" unfolding u by (rule dgrad_p_setD)
thus "s ∈ dgrad_set d m" by (simp add: ‹s = pp_of_term u› dgrad_set_def)
qed
ultimately obtain T where "finite T" and "T ⊆ S" and *: "⋀s. s ∈ S ⟹ (∃t∈T. t adds⇩t s)"
by (rule ex_finite_adds_term, blast)
define crit where "crit = (λt f. f ∈ pmdl F ∧ f ∈ dgrad_p_set d m ∧ f ≠ 0 ∧ t = lt f)"
have ex_crit: "t ∈ T ⟹ (∃f. crit t f)" for t
proof -
assume "t ∈ T"
from this ‹T ⊆ S› have "t ∈ S" ..
then obtain f where "f ∈ pmdl F ∧ f ∈ dgrad_p_set d m ∧ f ≠ 0" and "t = lt f"
unfolding S_def by blast
thus "∃f. crit t f" unfolding crit_def by blast
qed
define G where "G = (λt. SOME g. crit t g) ` T"
have G: "g ∈ G ⟹ g ∈ pmdl F ∧ g ∈ dgrad_p_set d m ∧ g ≠ 0" for g
proof -
assume "g ∈ G"
then obtain t where "t ∈ T" and g: "g = (SOME h. crit t h)" unfolding G_def ..
have "crit t g" unfolding g by (rule someI_ex, rule ex_crit, fact)
thus "g ∈ pmdl F ∧ g ∈ dgrad_p_set d m ∧ g ≠ 0" by (simp add: crit_def)
qed
have **: "t ∈ T ⟹ (∃g∈G. lt g = t)" for t
proof -
assume "t ∈ T"
define g where "g = (SOME h. crit t h)"
from ‹t ∈ T› have "g ∈ G" unfolding g_def G_def by blast
thus "∃g∈G. lt g = t"
proof
have "crit t g" unfolding g_def by (rule someI_ex, rule ex_crit, fact)
thus "lt g = t" by (simp add: crit_def)
qed
qed
have adds: "f ∈ pmdl F ⟹ f ∈ dgrad_p_set d m ⟹ f ≠ 0 ⟹ (∃g∈G. g ≠ 0 ∧ lt g adds⇩t lt f)" for f
proof -
assume "f ∈ pmdl F" and "f ∈ dgrad_p_set d m" and "f ≠ 0"
hence "lt f ∈ S" unfolding S_def by blast
hence "∃t∈T. t adds⇩t (lt f)" by (rule *)
then obtain t where "t ∈ T" and "t adds⇩t (lt f)" ..
from this(1) have "∃g∈G. lt g = t" by (rule **)
then obtain g where "g ∈ G" and "lt g = t" ..
show "∃g∈G. g ≠ 0 ∧ lt g adds⇩t lt f"
proof (intro bexI conjI)
from G[OF ‹g ∈ G›] show "g ≠ 0" by (elim conjE)
next
from ‹t adds⇩t lt f› show "lt g adds⇩t lt f" by (simp only: ‹lt g = t›)
qed fact
qed
have sub1: "pmdl G ⊆ pmdl F"
proof (rule pmdl.span_subset_spanI, rule)
fix g
assume "g ∈ G"
from G[OF this] show "g ∈ pmdl F" ..
qed
have sub2: "G ⊆ dgrad_p_set d m"
proof
fix g
assume "g ∈ G"
from G[OF this] show "g ∈ dgrad_p_set d m" by (elim conjE)
qed
show ?thesis
proof
from ‹finite T› show "finite G" unfolding G_def ..
next
from assms(1) sub2 adds show "is_Groebner_basis G"
proof (rule isGB_I_adds_lt)
fix f
assume "f ∈ pmdl G"
from this sub1 show "f ∈ pmdl F" ..
qed
next
show "pmdl G = pmdl F"
proof
show "pmdl F ⊆ pmdl G"
proof (rule pmdl.span_subset_spanI, rule)
fix f
assume "f ∈ F"
hence "f ∈ pmdl F" by (rule pmdl.span_base)
from ‹f ∈ F› assms(3) have "f ∈ dgrad_p_set d m" ..
with assms(1) sub2 sub1 _ ‹f ∈ pmdl F› have "(red G)⇧*⇧* f 0"
proof (rule is_red_implies_0_red_dgrad_p_set)
fix q
assume "q ∈ pmdl F" and "q ∈ dgrad_p_set d m" and "q ≠ 0"
hence "(∃g ∈ G. g ≠ 0 ∧ lt g adds⇩t lt q)" by (rule adds)
then obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt q" by blast
thus "is_red G q" using ‹q ≠ 0› is_red_indI1 by blast
qed
thus "f ∈ pmdl G" by (rule red_rtranclp_0_in_pmdl)
qed
qed fact
next
show "G ⊆ dgrad_p_set d m"
proof
fix g
assume "g ∈ G"
hence "g ∈ pmdl F ∧ g ∈ dgrad_p_set d m ∧ g ≠ 0" by (rule G)
thus "g ∈ dgrad_p_set d m" by (elim conjE)
qed
qed
qed
text ‹The preceding lemma justifies the following definition.›
definition some_GB :: "('t ⇒⇩0 'b) set ⇒ ('t ⇒⇩0 'b::field) set"
where "some_GB F = (SOME G. finite G ∧ is_Groebner_basis G ∧ pmdl G = pmdl F)"
lemma some_GB_props_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "finite (some_GB F) ∧ is_Groebner_basis (some_GB F) ∧ pmdl (some_GB F) = pmdl F"
proof -
from assms obtain G where "finite G" and "is_Groebner_basis G" and "pmdl G = pmdl F"
by (rule ex_finite_GB_dgrad_p_set)
hence "finite G ∧ is_Groebner_basis G ∧ pmdl G = pmdl F" by simp
thus "finite (some_GB F) ∧ is_Groebner_basis (some_GB F) ∧ pmdl (some_GB F) = pmdl F"
unfolding some_GB_def by (rule someI)
qed
lemma finite_some_GB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "finite (some_GB F)"
using some_GB_props_dgrad_p_set[OF assms] ..
lemma some_GB_isGB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "is_Groebner_basis (some_GB F)"
using some_GB_props_dgrad_p_set[OF assms] by (elim conjE)
lemma some_GB_pmdl_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "pmdl (some_GB F) = pmdl F"
using some_GB_props_dgrad_p_set[OF assms] by (elim conjE)
lemma finite_imp_finite_component_Keys:
assumes "finite F"
shows "finite (component_of_term ` Keys F)"
by (rule finite_imageI, rule finite_Keys, fact)
lemma finite_some_GB_finite: "finite F ⟹ finite (some_GB F)"
by (rule finite_some_GB_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma some_GB_isGB_finite: "finite F ⟹ is_Groebner_basis (some_GB F)"
by (rule some_GB_isGB_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma some_GB_pmdl_finite: "finite F ⟹ pmdl (some_GB F) = pmdl F"
by (rule some_GB_pmdl_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
text ‹Theory ‹Buchberger› implements an algorithm for effectively computing Gr\"obner bases.›
subsection ‹Relation ‹red_supset››
text ‹The following relation is needed for proving the termination of Buchberger's algorithm (i.\,e.
function ‹gb_schema_aux›).›
definition red_supset::"('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) set ⇒ bool" (infixl "⊐p" 50)
where "red_supset A B ≡ (∃p. is_red A p ∧ ¬ is_red B p) ∧ (∀p. is_red B p ⟶ is_red A p)"
lemma red_supsetE:
assumes "A ⊐p B"
obtains p where "is_red A p" and "¬ is_red B p"
proof -
from assms have "∃p. is_red A p ∧ ¬ is_red B p" by (simp add: red_supset_def)
from this obtain p where "is_red A p" and " ¬ is_red B p" by auto
thus ?thesis ..
qed
lemma red_supsetD:
assumes a1: "A ⊐p B" and a2: "is_red B p"
shows "is_red A p"
proof -
from assms have "∀p. is_red B p ⟶ is_red A p" by (simp add: red_supset_def)
hence "is_red B p ⟶ is_red A p" ..
from a2 this show ?thesis by simp
qed
lemma red_supsetI [intro]:
assumes "⋀q. is_red B q ⟹ is_red A q" and "is_red A p" and "¬ is_red B p"
shows "A ⊐p B"
unfolding red_supset_def using assms by auto
lemma red_supset_insertI:
assumes "x ≠ 0" and "¬ is_red A x"
shows "(insert x A) ⊐p A"
proof
fix q
assume "is_red A q"
thus "is_red (insert x A) q" unfolding is_red_alt
proof
fix a
assume "red A q a"
from red_unionI2[OF this, of "{x}"] have "red (insert x A) q a" by simp
show "∃qa. red (insert x A) q qa"
proof
show "red (insert x A) q a" by fact
qed
qed
next
show "is_red (insert x A) x" unfolding is_red_alt
proof
from red_unionI1[OF red_self[OF ‹x ≠ 0›], of A] show "red (insert x A) x 0" by simp
qed
next
show "¬ is_red A x" by fact
qed
lemma red_supset_transitive:
assumes "A ⊐p B" and "B ⊐p C"
shows "A ⊐p C"
proof -
from assms(2) obtain p where "is_red B p" and "¬ is_red C p" by (rule red_supsetE)
show ?thesis
proof
fix q
assume "is_red C q"
with assms(2) have "is_red B q" by (rule red_supsetD)
with assms(1) show "is_red A q" by (rule red_supsetD)
next
from assms(1) ‹is_red B p› show "is_red A p" by (rule red_supsetD)
qed fact
qed
lemma red_supset_wf_on:
assumes "dickson_grading d" and "finite K"
shows "wfp_on (⊐p) (Pow (dgrad_p_set d m) ∩ {F. component_of_term ` Keys F ⊆ K})"
proof (rule wfp_onI_chain, rule, erule exE)
let ?A = "dgrad_p_set d m"
fix f::"nat ⇒ (('t ⇒⇩0 'b) set)"
assume "∀i. f i ∈ Pow ?A ∩ {F. component_of_term ` Keys F ⊆ K} ∧ f (Suc i) ⊐p f i"
hence a1_subset: "f i ⊆ ?A" and comp_sub: "component_of_term ` Keys (f i) ⊆ K"
and a1: "f (Suc i) ⊐p f i" for i by simp_all
have a1_trans: "i < j ⟹ f j ⊐p f i" for i j
proof -
assume "i < j"
thus "f j ⊐p f i"
proof (induct j)
case 0
thus ?case by simp
next
case (Suc j)
from Suc(2) have "i = j ∨ i < j" by auto
thus ?case
proof
assume "i = j"
show ?thesis unfolding ‹i = j› by (fact a1)
next
assume "i < j"
from a1 have "f (Suc j) ⊐p f j" .
also from ‹i < j› have "... ⊐p f i" by (rule Suc(1))
finally(red_supset_transitive) show ?thesis .
qed
qed
qed
have a2: "∃p ∈ f (Suc i). ∃q. is_red {p} q ∧ ¬ is_red (f i) q" for i
proof -
from a1 have "f (Suc i) ⊐p f i" .
then obtain q where red: "is_red (f (Suc i)) q" and irred: "¬ is_red (f i) q"
by (rule red_supsetE)
from red obtain p where "p ∈ f (Suc i)" and "is_red {p} q" by (rule is_red_singletonI)
show "∃p∈f (Suc i). ∃q. is_red {p} q ∧ ¬ is_red (f i) q"
proof
show "∃q. is_red {p} q ∧ ¬ is_red (f i) q"
proof (intro exI, intro conjI)
show "is_red {p} q" by fact
qed (fact)
next
show "p ∈ f (Suc i)" by fact
qed
qed
let ?P = "λi p. p ∈ (f (Suc i)) ∧ (∃q. is_red {p} q ∧ ¬ is_red (f i) q)"
define g where "g ≡ λi::nat. (SOME p. ?P i p)"
have a3: "?P i (g i)" for i
proof -
from a2[of i] obtain gi where "gi ∈ f (Suc i)" and "∃q. is_red {gi} q ∧ ¬ is_red (f i) q" ..
show ?thesis unfolding g_def by (rule someI[of _ gi], intro conjI, fact+)
qed
have a4: "i < j ⟹ ¬ lt (g i) adds⇩t (lt (g j))" for i j
proof
assume "i < j" and adds: "lt (g i) adds⇩t lt (g j)"
from a3 have "∃q. is_red {g j} q ∧ ¬ is_red (f j) q" ..
then obtain q where redj: "is_red {g j} q" and "¬ is_red (f j) q" by auto
have *: "¬ is_red (f (Suc i)) q"
proof -
from ‹i < j› have "i + 1 < j ∨ i + 1 = j" by auto
thus ?thesis
proof
assume "i + 1 < j"
from red_supsetD[OF a1_trans[rule_format, OF this], of q] ‹¬ is_red (f j) q›
show ?thesis by auto
next
assume "i + 1 = j"
thus ?thesis using ‹¬ is_red (f j) q› by simp
qed
qed
from a3 have "g i ∈ f (i + 1)" and redi: "∃q. is_red {g i} q ∧ ¬ is_red (f i) q" by simp_all
have "¬ is_red {g i} q"
proof
assume "is_red {g i} q"
from is_red_singletonD[OF this ‹g i ∈ f (i + 1)›] * show False by simp
qed
have "g i ≠ 0"
proof -
from redi obtain q0 where "is_red {g i} q0" by auto
from is_red_singleton_not_0[OF this] show ?thesis .
qed
from ‹¬ is_red {g i} q› is_red_singleton_trans[OF redj adds ‹g i ≠ 0›] show False by simp
qed
from _ assms(2) have a5: "finite (component_of_term ` range (lt ∘ g))"
proof (rule finite_subset)
show "component_of_term ` range (lt ∘ g) ⊆ K"
proof (rule, elim imageE, simp)
fix i
from a3 have "g i ∈ f (Suc i)" and "∃q. is_red {g i} q ∧ ¬ is_red (f i) q" by simp_all
from this(2) obtain q where "is_red {g i} q" by auto
hence "g i ≠ 0" by (rule is_red_singleton_not_0)
hence "lt (g i) ∈ keys (g i)" by (rule lt_in_keys)
hence "component_of_term (lt (g i)) ∈ component_of_term ` keys (g i)" by simp
also have "... ⊆ component_of_term ` Keys (f (Suc i))"
by (rule image_mono, rule keys_subset_Keys, fact)
also have "... ⊆ K" by (fact comp_sub)
finally show "component_of_term (lt (g i)) ∈ K" .
qed
qed
have a6: "pp_of_term ` range (lt ∘ g) ⊆ dgrad_set d m"
proof (rule, elim imageE, simp)
fix i
from a3 have "g i ∈ f (Suc i)" and "∃q. is_red {g i} q ∧ ¬ is_red (f i) q" by simp_all
from this(2) obtain q where "is_red {g i} q" by auto
hence "g i ≠ 0" by (rule is_red_singleton_not_0)
from a1_subset ‹g i ∈ f (Suc i)› have "g i ∈ ?A" ..
from this ‹g i ≠ 0› have "d (lp (g i)) ≤ m" by (rule dgrad_p_setD_lp)
thus "lp (g i) ∈ dgrad_set d m" by (rule dgrad_setI)
qed
from assms(1) a5 a6 obtain i j where "i < j" and "(lt ∘ g) i adds⇩t (lt ∘ g) j" by (rule Dickson_termE)
from this a4[OF ‹i < j›] show False by simp
qed
end
lemma in_lex_prod_alt:
"(x, y) ∈ r <*lex*> s ⟷ (((fst x), (fst y)) ∈ r ∨ (fst x = fst y ∧ ((snd x), (snd y)) ∈ s))"
by (metis in_lex_prod prod.collapse prod.inject surj_pair)
subsection ‹Context @{locale od_term}›
context od_term
begin
lemmas red_wf = red_wf_dgrad_p_set[OF dickson_grading_zero subset_dgrad_p_set_zero]
lemmas Buchberger_criterion = Buchberger_criterion_dgrad_p_set[OF dickson_grading_zero subset_dgrad_p_set_zero]
end
end
Theory Algorithm_Schema
section ‹A General Algorithm Schema for Computing Gr\"obner Bases›
theory Algorithm_Schema
imports General Groebner_Bases
begin
text ‹This theory formalizes a general algorithm schema for computing Gr\"obner bases, generalizing
Buchberger's original critical-pair/completion algorithm. The algorithm schema depends on several
functional parameters that can be instantiated by a variety of concrete functions. Possible instances
yield Buchberger's algorithm, Faug\`ere's F4 algorithm, and (as far as we can tell) even his F5
algorithm.›
subsection ‹@{term processed}›
definition minus_pairs (infixl "-⇩p" 65) where "minus_pairs A B = A - (B ∪ prod.swap ` B)"
definition Int_pairs (infixl "∩⇩p" 65) where "Int_pairs A B = A ∩ (B ∪ prod.swap ` B)"
definition in_pair (infix "∈⇩p" 50) where "in_pair p A ⟷ (p ∈ A ∪ prod.swap ` A)"
definition subset_pairs (infix "⊆⇩p" 50) where "subset_pairs A B ⟷ (∀x. x ∈⇩p A ⟶ x ∈⇩p B)"
abbreviation not_in_pair (infix "∉⇩p" 50) where "not_in_pair p A ≡ ¬ p ∈⇩p A"
lemma in_pair_alt: "p ∈⇩p A ⟷ (p ∈ A ∨ prod.swap p ∈ A)"
by (metis (mono_tags, lifting) UnCI UnE image_iff in_pair_def prod.collapse swap_simp)
lemma in_pair_iff: "(a, b) ∈⇩p A ⟷ ((a, b) ∈ A ∨ (b, a) ∈ A)"
by (simp add: in_pair_alt)
lemma in_pair_minus_pairs [simp]: "p ∈⇩p A -⇩p B ⟷ (p ∈⇩p A ∧ p ∉⇩p B)"
by (metis Diff_iff in_pair_def in_pair_iff minus_pairs_def prod.collapse)
lemma in_minus_pairs [simp]: "p ∈ A -⇩p B ⟷ (p ∈ A ∧ p ∉⇩p B)"
by (metis Diff_iff in_pair_def minus_pairs_def)
lemma in_pair_Int_pairs [simp]: "p ∈⇩p A ∩⇩p B ⟷ (p ∈⇩p A ∧ p ∈⇩p B)"
by (metis (no_types, hide_lams) Int_iff Int_pairs_def in_pair_alt in_pair_def old.prod.exhaust swap_simp)
lemma in_pair_Un [simp]: "p ∈⇩p A ∪ B ⟷ (p ∈⇩p A ∨ p ∈⇩p B)"
by (metis (mono_tags, lifting) UnE UnI1 UnI2 image_Un in_pair_def)
lemma in_pair_trans [trans]:
assumes "p ∈⇩p A" and "A ⊆ B"
shows "p ∈⇩p B"
using assms by (auto simp: in_pair_def)
lemma in_pair_same [simp]: "p ∈⇩p A × A ⟷ p ∈ A × A"
by (auto simp: in_pair_def)
lemma subset_pairsI [intro]:
assumes "⋀x. x ∈⇩p A ⟹ x ∈⇩p B"
shows "A ⊆⇩p B"
unfolding subset_pairs_def using assms by blast
lemma subset_pairsD [trans]:
assumes "x ∈⇩p A" and "A ⊆⇩p B"
shows "x ∈⇩p B"
using assms unfolding subset_pairs_def by blast
definition processed :: "('a × 'a) ⇒ 'a list ⇒ ('a × 'a) list ⇒ bool"
where "processed p xs ps ⟷ p ∈ set xs × set xs ∧ p ∉⇩p set ps"
lemma processed_alt:
"processed (a, b) xs ps ⟷ ((a ∈ set xs) ∧ (b ∈ set xs) ∧ (a, b) ∉⇩p set ps)"
unfolding processed_def by auto
lemma processedI:
assumes "a ∈ set xs" and "b ∈ set xs" and "(a, b) ∉⇩p set ps"
shows "processed (a, b) xs ps"
unfolding processed_alt using assms by simp
lemma processedD1:
assumes "processed (a, b) xs ps"
shows "a ∈ set xs"
using assms by (simp add: processed_alt)
lemma processedD2:
assumes "processed (a, b) xs ps"
shows "b ∈ set xs"
using assms by (simp add: processed_alt)
lemma processedD3:
assumes "processed (a, b) xs ps"
shows "(a, b) ∉⇩p set ps"
using assms by (simp add: processed_alt)
lemma processed_Nil: "processed (a, b) xs [] ⟷ (a ∈ set xs ∧ b ∈ set xs)"
by (simp add: processed_alt in_pair_iff)
lemma processed_Cons:
assumes "processed (a, b) xs ps"
and a1: "a = p ⟹ b = q ⟹ thesis"
and a2: "a = q ⟹ b = p ⟹ thesis"
and a3: "processed (a, b) xs ((p, q) # ps) ⟹ thesis"
shows thesis
proof -
from assms(1) have "a ∈ set xs" and "b ∈ set xs" and "(a, b) ∉⇩p set ps"
by (simp_all add: processed_alt)
show ?thesis
proof (cases "(a, b) = (p, q)")
case True
hence "a = p" and "b = q" by simp_all
thus ?thesis by (rule a1)
next
case False
with ‹(a, b) ∉⇩p set ps› have *: "(a, b) ∉ set ((p, q) # ps)" by (auto simp: in_pair_iff)
show ?thesis
proof (cases "(b, a) = (p, q)")
case True
hence "a = q" and "b = p" by simp_all
thus ?thesis by (rule a2)
next
case False
with ‹(a, b) ∉⇩p set ps› have "(b, a) ∉ set ((p, q) # ps)" by (auto simp: in_pair_iff)
with * have "(a, b) ∉⇩p set ((p, q) # ps)" by (simp add: in_pair_iff)
with ‹a ∈ set xs› ‹b ∈ set xs› have "processed (a, b) xs ((p, q) # ps)"
by (rule processedI)
thus ?thesis by (rule a3)
qed
qed
qed
lemma processed_minus:
assumes "processed (a, b) xs (ps -- qs)"
and a1: "(a, b) ∈⇩p set qs ⟹ thesis"
and a2: "processed (a, b) xs ps ⟹ thesis"
shows thesis
proof -
from assms(1) have "a ∈ set xs" and "b ∈ set xs" and "(a, b) ∉⇩p set (ps -- qs)"
by (simp_all add: processed_alt)
show ?thesis
proof (cases "(a, b) ∈⇩p set qs")
case True
thus ?thesis by (rule a1)
next
case False
with ‹(a, b) ∉⇩p set (ps -- qs)› have "(a, b) ∉⇩p set ps"
by (auto simp: set_diff_list in_pair_iff)
with ‹a ∈ set xs› ‹b ∈ set xs› have "processed (a, b) xs ps"
by (rule processedI)
thus ?thesis by (rule a2)
qed
qed
subsection ‹Algorithm Schema›
subsubsection ‹‹const_lt_component››
context ordered_term
begin
definition const_lt_component :: "('t ⇒⇩0 'b::zero) ⇒ 'k option"
where "const_lt_component p =
(let v = lt p in if pp_of_term v = 0 then Some (component_of_term v) else None)"
lemma const_lt_component_SomeI:
assumes "lp p = 0" and "component_of_term (lt p) = cmp"
shows "const_lt_component p = Some cmp"
using assms by (simp add: const_lt_component_def)
lemma const_lt_component_SomeD1:
assumes "const_lt_component p = Some cmp"
shows "lp p = 0"
using assms by (simp add: const_lt_component_def Let_def split: if_split_asm)
lemma const_lt_component_SomeD2:
assumes "const_lt_component p = Some cmp"
shows "component_of_term (lt p) = cmp"
using assms by (simp add: const_lt_component_def Let_def split: if_split_asm)
lemma const_lt_component_subset:
"const_lt_component ` (B - {0}) - {None} ⊆ Some ` component_of_term ` Keys B"
proof
fix k
assume "k ∈ const_lt_component ` (B - {0}) - {None}"
hence "k ∈ const_lt_component ` (B - {0})" and "k ≠ None" by simp_all
from this(1) obtain p where "p ∈ B - {0}" and "k = const_lt_component p" ..
moreover from ‹k ≠ None› obtain k' where "k = Some k'" by blast
ultimately have "const_lt_component p = Some k'" and "p ∈ B" and "p ≠ 0" by simp_all
from this(1) have "component_of_term (lt p) = k'" by (rule const_lt_component_SomeD2)
moreover have "lt p ∈ Keys B" by (rule in_KeysI, rule lt_in_keys, fact+)
ultimately have "k' ∈ component_of_term ` Keys B" by fastforce
thus "k ∈ Some ` component_of_term ` Keys B" by (simp add: ‹k = Some k'›)
qed
corollary card_const_lt_component_le:
assumes "finite B"
shows "card (const_lt_component ` (B - {0}) - {None}) ≤ card (component_of_term ` Keys B)"
proof (rule surj_card_le)
show "finite (component_of_term ` Keys B)"
by (intro finite_imageI finite_Keys, fact)
next
show "const_lt_component ` (B - {0}) - {None} ⊆ Some ` component_of_term ` Keys B"
by (fact const_lt_component_subset)
qed
end
subsubsection ‹Type synonyms›
type_synonym ('a, 'b, 'c) pdata' = "('a ⇒⇩0 'b) × 'c"
type_synonym ('a, 'b, 'c) pdata = "('a ⇒⇩0 'b) × nat × 'c"
type_synonym ('a, 'b, 'c) pdata_pair = "('a, 'b, 'c) pdata × ('a, 'b, 'c) pdata"
type_synonym ('a, 'b, 'c, 'd) selT = "('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒
('a, 'b, 'c) pdata_pair list ⇒ nat × 'd ⇒ ('a, 'b, 'c) pdata_pair list"
type_synonym ('a, 'b, 'c, 'd) complT = "('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒
('a, 'b, 'c) pdata_pair list ⇒ ('a, 'b, 'c) pdata_pair list ⇒
nat × 'd ⇒ (('a, 'b, 'c) pdata' list × 'd)"
type_synonym ('a, 'b, 'c, 'd) apT = "('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒
('a, 'b, 'c) pdata_pair list ⇒ ('a, 'b, 'c) pdata list ⇒ nat × 'd ⇒
('a, 'b, 'c) pdata_pair list"
type_synonym ('a, 'b, 'c, 'd) abT = "('a, 'b, 'c) pdata list ⇒ ('a, 'b, 'c) pdata list ⇒
('a, 'b, 'c) pdata list ⇒ nat × 'd ⇒ ('a, 'b, 'c) pdata list"
subsubsection ‹Specification of the @{emph ‹selector›} parameter›
definition sel_spec :: "('a, 'b, 'c, 'd) selT ⇒ bool"
where "sel_spec sel ⟷
(∀gs bs ps data. ps ≠ [] ⟶ (sel gs bs ps data ≠ [] ∧ set (sel gs bs ps data) ⊆ set ps))"
lemma sel_specI:
assumes "⋀gs bs ps data. ps ≠ [] ⟹ (sel gs bs ps data ≠ [] ∧ set (sel gs bs ps data) ⊆ set ps)"
shows "sel_spec sel"
unfolding sel_spec_def using assms by blast
lemma sel_specD1:
assumes "sel_spec sel" and "ps ≠ []"
shows "sel gs bs ps data ≠ []"
using assms unfolding sel_spec_def by blast
lemma sel_specD2:
assumes "sel_spec sel" and "ps ≠ []"
shows "set (sel gs bs ps data) ⊆ set ps"
using assms unfolding sel_spec_def by blast
subsubsection ‹Specification of the @{emph ‹add-basis›} parameter›
definition ab_spec :: "('a, 'b, 'c, 'd) abT ⇒ bool"
where "ab_spec ab ⟷
(∀gs bs ns data. ns ≠ [] ⟶ set (ab gs bs ns data) = set bs ∪ set ns) ∧
(∀gs bs data. ab gs bs [] data = bs)"
lemma ab_specI:
assumes "⋀gs bs ns data. ns ≠ [] ⟹ set (ab gs bs ns data) = set bs ∪ set ns"
and "⋀gs bs data. ab gs bs [] data = bs"
shows "ab_spec ab"
unfolding ab_spec_def using assms by blast
lemma ab_specD1:
assumes "ab_spec ab"
shows "set (ab gs bs ns data) = set bs ∪ set ns"
using assms unfolding ab_spec_def by (metis empty_set sup_bot.right_neutral)
lemma ab_specD2:
assumes "ab_spec ab"
shows "ab gs bs [] data = bs"
using assms unfolding ab_spec_def by blast
subsubsection ‹Specification of the @{emph ‹add-pairs›} parameter›
definition unique_idx :: "('t, 'b, 'c) pdata list ⇒ (nat × 'd) ⇒ bool"
where "unique_idx bs data ⟷
(∀f∈set bs. ∀g∈set bs. fst (snd f) = fst (snd g) ⟶ f = g) ∧
(∀f∈set bs. fst (snd f) < fst data)"
lemma unique_idxI:
assumes "⋀f g. f ∈ set bs ⟹ g ∈ set bs ⟹ fst (snd f) = fst (snd g) ⟹ f = g"
and "⋀f. f ∈ set bs ⟹ fst (snd f) < fst data"
shows "unique_idx bs data"
unfolding unique_idx_def using assms by blast
lemma unique_idxD1:
assumes "unique_idx bs data" and "f ∈ set bs" and "g ∈ set bs" and "fst (snd f) = fst (snd g)"
shows "f = g"
using assms unfolding unique_idx_def by blast
lemma unique_idxD2:
assumes "unique_idx bs data" and "f ∈ set bs"
shows "fst (snd f) < fst data"
using assms unfolding unique_idx_def by blast
lemma unique_idx_Nil: "unique_idx [] data"
by (simp add: unique_idx_def)
lemma unique_idx_subset:
assumes "unique_idx bs data" and "set bs' ⊆ set bs"
shows "unique_idx bs' data"
proof (rule unique_idxI)
fix f g
assume "f ∈ set bs'" and "g ∈ set bs'"
with assms have "unique_idx bs data" and "f ∈ set bs" and "g ∈ set bs" by auto
moreover assume "fst (snd f) = fst (snd g)"
ultimately show "f = g" by (rule unique_idxD1)
next
fix f
assume "f ∈ set bs'"
with assms(2) have "f ∈ set bs" by auto
with assms(1) show "fst (snd f) < fst data" by (rule unique_idxD2)
qed
context gd_term
begin
definition ap_spec :: "('t, 'b::field, 'c, 'd) apT ⇒ bool"
where "ap_spec ap ⟷ (∀gs bs ps hs data.
set (ap gs bs ps hs data) ⊆ set ps ∪ (set hs × (set gs ∪ set bs ∪ set hs)) ∧
(∀B d m. ∀h∈set hs. ∀g∈set gs ∪ set bs ∪ set hs. dickson_grading d ⟶
set gs ∪ set bs ∪ set hs ⊆ B ⟶ fst ` B ⊆ dgrad_p_set d m ⟶
set ps ⊆ set bs × (set gs ∪ set bs) ⟶ unique_idx (gs @ bs @ hs) data ⟶
is_Groebner_basis (fst ` set gs) ⟶ h ≠ g ⟶ fst h ≠ 0 ⟶ fst g ≠ 0 ⟶
(∀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟶ fst a ≠ 0 ⟶ fst b ≠ 0 ⟶
crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟶
(∀a b. a ∈ set gs ∪ set bs ⟶ b ∈ set gs ∪ set bs ⟶ fst a ≠ 0 ⟶ fst b ≠ 0 ⟶
crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟶
crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)) ∧
(∀B d m. ∀h g. dickson_grading d ⟶
set gs ∪ set bs ∪ set hs ⊆ B ⟶ fst ` B ⊆ dgrad_p_set d m ⟶
set ps ⊆ set bs × (set gs ∪ set bs) ⟶ (set gs ∪ set bs) ∩ set hs = {} ⟶
unique_idx (gs @ bs @ hs) data ⟶ is_Groebner_basis (fst ` set gs) ⟶
h ≠ g ⟶ fst h ≠ 0 ⟶ fst g ≠ 0 ⟶
(h, g) ∈ set ps -⇩p set (ap gs bs ps hs data) ⟶
(∀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟶ (a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) ⟶
fst a ≠ 0 ⟶ fst b ≠ 0 ⟶ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟶
crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)))"
text ‹Informally, ‹ap_spec ap› means that, for suitable arguments ‹gs›, ‹bs›, ‹ps› and ‹hs›,
the value of ‹ap gs bs ps hs› is a list of pairs ‹ps'› such that for every element ‹(a, b)› missing in ‹ps'›
there exists a set of pairs ‹C› by reference to which ‹(a, b)› can be discarded, i.\,e. as soon as
all critical pairs of the elements in ‹C› can be connected below some set ‹B›, the same is true for
the critical pair of ‹(a, b)›.›
lemma ap_specI:
assumes "⋀gs bs ps hs data. set (ap gs bs ps hs data) ⊆ set ps ∪ (set hs × (set gs ∪ set bs ∪ set hs))"
assumes "⋀gs bs ps hs data B d m h g. dickson_grading d ⟹
set gs ∪ set bs ∪ set hs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹
h ∈ set hs ⟹ g ∈ set gs ∪ set bs ∪ set hs ⟹
set ps ⊆ set bs × (set gs ∪ set bs) ⟹ unique_idx (gs @ bs @ hs) data ⟹
is_Groebner_basis (fst ` set gs) ⟹ h ≠ g ⟹ fst h ≠ 0 ⟹ fst g ≠ 0 ⟹
(⋀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟹
(⋀a b. a ∈ set gs ∪ set bs ⟹ b ∈ set gs ∪ set bs ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟹
crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)"
assumes "⋀gs bs ps hs data B d m h g. dickson_grading d ⟹
set gs ∪ set bs ∪ set hs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹
set ps ⊆ set bs × (set gs ∪ set bs) ⟹ (set gs ∪ set bs) ∩ set hs = {} ⟹
unique_idx (gs @ bs @ hs) data ⟹ is_Groebner_basis (fst ` set gs) ⟹ h ≠ g ⟹
fst h ≠ 0 ⟹ fst g ≠ 0 ⟹ (h, g) ∈ set ps -⇩p set (ap gs bs ps hs data) ⟹
(⋀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟹ (a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) ⟹
fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)) ⟹
crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)"
shows "ap_spec ap"
unfolding ap_spec_def
apply (intro allI conjI impI)
subgoal by (rule assms(1))
subgoal by (intro ballI impI, rule assms(2), blast+)
subgoal by (rule assms(3), blast+)
done
lemma ap_specD1:
assumes "ap_spec ap"
shows "set (ap gs bs ps hs data) ⊆ set ps ∪ (set hs × (set gs ∪ set bs ∪ set hs))"
using assms unfolding ap_spec_def by (elim allE conjE) (assumption)
lemma ap_specD2:
assumes "ap_spec ap" and "dickson_grading d" and "set gs ∪ set bs ∪ set hs ⊆ B"
and "fst ` B ⊆ dgrad_p_set d m" and "(h, g) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)"
and "set ps ⊆ set bs × (set gs ∪ set bs)" and "unique_idx (gs @ bs @ hs) data"
and "is_Groebner_basis (fst ` set gs)" and "h ≠ g" and "fst h ≠ 0" and "fst g ≠ 0"
and "⋀a b. (a, b) ∈⇩p set (ap gs bs ps hs data) ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
and "⋀a b. a ∈ set gs ∪ set bs ⟹ b ∈ set gs ∪ set bs ⟹ fst a ≠ 0 ⟹ fst b ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
shows "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)"
proof -
from assms(5) have "(h, g) ∈ set hs × (set gs ∪ set bs ∪ set hs) ∨ (g, h) ∈ set hs × (set gs ∪ set bs ∪ set hs)"
by (simp only: in_pair_iff)
thus ?thesis
proof
assume "(h, g) ∈ set hs × (set gs ∪ set bs ∪ set hs)"
hence "h ∈ set hs" and "g ∈ set gs ∪ set bs ∪ set hs" by simp_all
from assms(1)[unfolded ap_spec_def, rule_format, of gs bs ps hs data] assms(2-4) this assms (6-)
show ?thesis by metis
next
assume "(g, h) ∈ set hs × (set gs ∪ set bs ∪ set hs)"
hence "g ∈ set hs" and "h ∈ set gs ∪ set bs ∪ set hs" by simp_all
hence "crit_pair_cbelow_on d m (fst ` B) (fst g) (fst h)"
using assms(1)[unfolded ap_spec_def, rule_format, of gs bs ps hs data]
assms(2,3,4,6,7,8,10,11,12,13) assms(9)[symmetric]
by metis
thus ?thesis by (rule crit_pair_cbelow_sym)
qed
qed
lemma ap_specD3:
assumes "ap_spec ap" and "dickson_grading d" and "set gs ∪ set bs ∪ set hs ⊆ B"
and "fst ` B ⊆ dgrad_p_set d m" and "set ps ⊆ set bs × (set gs ∪ set bs)"
and "(set gs ∪ set bs) ∩ set hs = {}" and "unique_idx (gs @ bs @ hs) data"
and "is_Groebner_basis (fst ` set gs)" and "h ≠ g" and "fst h ≠ 0" and "fst g ≠ 0"
and "(h, g) ∈⇩p set ps -⇩p set (ap gs bs ps hs data)"
and "⋀a b. a ∈ set hs ⟹ b ∈ set gs ∪ set bs ∪ set hs ⟹ (a, b) ∈⇩p set (ap gs bs ps hs data) ⟹
fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
shows "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)"
proof -
have *: "crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
if 1: "(a, b) ∈⇩p set (ap gs bs ps hs data)" and 2: "(a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)"
and 3: "fst a ≠ 0" and 4: "fst b ≠ 0" for a b
proof -
from 2 have "(a, b) ∈ set hs × (set gs ∪ set bs ∪ set hs) ∨ (b, a) ∈ set hs × (set gs ∪ set bs ∪ set hs)"
by (simp only: in_pair_iff)
thus ?thesis
proof
assume "(a, b) ∈ set hs × (set gs ∪ set bs ∪ set hs)"
hence "a ∈ set hs" and "b ∈ set gs ∪ set bs ∪ set hs" by simp_all
thus ?thesis using 1 3 4 by (rule assms(13))
next
assume "(b, a) ∈ set hs × (set gs ∪ set bs ∪ set hs)"
hence "b ∈ set hs" and "a ∈ set gs ∪ set bs ∪ set hs" by simp_all
moreover from 1 have "(b, a) ∈⇩p set (ap gs bs ps hs data)" by (auto simp: in_pair_iff)
ultimately have "crit_pair_cbelow_on d m (fst ` B) (fst b) (fst a)" using 4 3 by (rule assms(13))
thus ?thesis by (rule crit_pair_cbelow_sym)
qed
qed
from assms(12) have "(h, g) ∈ set ps -⇩p set (ap gs bs ps hs data) ∨
(g, h) ∈ set ps -⇩p set (ap gs bs ps hs data)" by (simp only: in_pair_iff)
thus ?thesis
proof
assume "(h, g) ∈ set ps -⇩p set (ap gs bs ps hs data)"
with assms(1)[unfolded ap_spec_def, rule_format, of gs bs ps hs data] assms(2-11)
show ?thesis using assms(10) * by metis
next
assume "(g, h) ∈ set ps -⇩p set (ap gs bs ps hs data)"
with assms(1)[unfolded ap_spec_def, rule_format, of gs bs ps hs data] assms(2-11)
have "crit_pair_cbelow_on d m (fst ` B) (fst g) (fst h)" using assms(10) * by metis
thus ?thesis by (rule crit_pair_cbelow_sym)
qed
qed
lemma ap_spec_Nil_subset:
assumes "ap_spec ap"
shows "set (ap gs bs ps [] data) ⊆ set ps"
using ap_specD1[OF assms] by fastforce
lemma ap_spec_fst_subset:
assumes "ap_spec ap"
shows "fst ` set (ap gs bs ps hs data) ⊆ fst ` set ps ∪ set hs"
proof -
from ap_specD1[OF assms]
have "fst ` set (ap gs bs ps hs data) ⊆ fst ` (set ps ∪ set hs × (set gs ∪ set bs ∪ set hs))"
by (rule image_mono)
thus ?thesis by auto
qed
lemma ap_spec_snd_subset:
assumes "ap_spec ap"
shows "snd ` set (ap gs bs ps hs data) ⊆ snd ` set ps ∪ set gs ∪ set bs ∪ set hs"
proof -
from ap_specD1[OF assms]
have "snd ` set (ap gs bs ps hs data) ⊆ snd ` (set ps ∪ set hs × (set gs ∪ set bs ∪ set hs))"
by (rule image_mono)
thus ?thesis by auto
qed
lemma ap_spec_inE:
assumes "ap_spec ap" and "(p, q) ∈ set (ap gs bs ps hs data)"
assumes 1: "(p, q) ∈ set ps ⟹ thesis"
assumes 2: "p ∈ set hs ⟹ q ∈ set gs ∪ set bs ∪ set hs ⟹ thesis"
shows thesis
proof -
from assms(2) ap_specD1[OF assms(1)] have "(p, q) ∈ set ps ∪ set hs × (set gs ∪ set bs ∪ set hs)" ..
thus ?thesis
proof
assume "(p, q) ∈ set ps"
thus ?thesis by (rule 1)
next
assume "(p, q) ∈ set hs × (set gs ∪ set bs ∪ set hs)"
hence "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" by blast+
thus ?thesis by (rule 2)
qed
qed
lemma subset_Times_ap:
assumes "ap_spec ap" and "ab_spec ab" and "set ps ⊆ set bs × (set gs ∪ set bs)"
shows "set (ap gs bs (ps -- sps) hs data) ⊆ set (ab gs bs hs data) × (set gs ∪ set (ab gs bs hs data))"
proof
fix p q
assume "(p, q) ∈ set (ap gs bs (ps -- sps) hs data)"
with assms(1) show "(p, q) ∈ set (ab gs bs hs data) × (set gs ∪ set (ab gs bs hs data))"
proof (rule ap_spec_inE)
assume "(p, q) ∈ set (ps -- sps)"
hence "(p, q) ∈ set ps" by (simp add: set_diff_list)
from this assms(3) have "(p, q) ∈ set bs × (set gs ∪ set bs)" ..
hence "p ∈ set bs" and "q ∈ set gs ∪ set bs" by blast+
thus ?thesis by (auto simp add: ab_specD1[OF assms(2)])
next
assume "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs"
thus ?thesis by (simp add: ab_specD1[OF assms(2)])
qed
qed
subsubsection ‹Function ‹args_to_set››
definition args_to_set :: "('t, 'b::field, 'c) pdata list × ('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair list ⇒ ('t ⇒⇩0 'b) set"
where "args_to_set x = fst ` (set (fst x) ∪ set (fst (snd x)) ∪ fst ` set (snd (snd x)) ∪ snd ` set (snd (snd x)))"
lemma args_to_set_alt:
"args_to_set (gs, bs, ps) = fst ` set gs ∪ fst ` set bs ∪ fst ` fst ` set ps ∪ fst ` snd ` set ps"
by (simp add: args_to_set_def image_Un)
lemma args_to_set_subset_Times:
assumes "set ps ⊆ set bs × (set gs ∪ set bs)"
shows "args_to_set (gs, bs, ps) = fst ` set gs ∪ fst ` set bs"
unfolding args_to_set_alt using assms by auto
lemma args_to_set_subset:
assumes "ap_spec ap" and "ab_spec ab"
shows "args_to_set (gs, ab gs bs hs data, ap gs bs ps hs data) ⊆
fst ` (set gs ∪ set bs ∪ fst ` set ps ∪ snd ` set ps ∪ set hs)" (is "?l ⊆ fst ` ?r")
proof (simp only: args_to_set_alt Un_subset_iff, intro conjI image_mono)
show "set (ab gs bs hs data) ⊆ ?r" by (auto simp add: ab_specD1[OF assms(2)])
next
from assms(1) have "fst ` set (ap gs bs ps hs data) ⊆ fst ` set ps ∪ set hs"
by (rule ap_spec_fst_subset)
thus "fst ` set (ap gs bs ps hs data) ⊆ ?r" by blast
next
from assms(1) have "snd ` set (ap gs bs ps hs data) ⊆ snd ` set ps ∪ set gs ∪ set bs ∪ set hs"
by (rule ap_spec_snd_subset)
thus "snd ` set (ap gs bs ps hs data) ⊆ ?r" by blast
qed blast
lemma args_to_set_alt2:
assumes "ap_spec ap" and "ab_spec ab" and "set ps ⊆ set bs × (set gs ∪ set bs)"
shows "args_to_set (gs, ab gs bs hs data, ap gs bs (ps -- sps) hs data) =
fst ` (set gs ∪ set bs ∪ set hs)" (is "?l = fst ` ?r")
proof
from assms(1, 2) have "?l ⊆ fst ` (set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs)"
by (rule args_to_set_subset)
also have "... ⊆ fst ` ?r"
proof (rule image_mono)
have "set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs ⊆
set gs ∪ set bs ∪ fst ` set ps ∪ snd ` set ps ∪ set hs" by (auto simp: set_diff_list)
also from assms(3) have "... ⊆ ?r" by fastforce
finally show "set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs ⊆ ?r" .
qed
finally show "?l ⊆ fst ` ?r" .
next
from assms(2) have eq: "set (ab gs bs hs data) = set bs ∪ set hs" by (rule ab_specD1)
have "fst ` ?r ⊆ fst ` set gs ∪ fst ` set (ab gs bs hs data)" unfolding eq using assms(3)
by fastforce
also have "... ⊆ ?l" unfolding args_to_set_alt by fastforce
finally show "fst ` ?r ⊆ ?l" .
qed
lemma args_to_set_subset1:
assumes "set gs1 ⊆ set gs2"
shows "args_to_set (gs1, bs, ps) ⊆ args_to_set (gs2, bs, ps)"
using assms by (auto simp add: args_to_set_alt)
lemma args_to_set_subset2:
assumes "set bs1 ⊆ set bs2"
shows "args_to_set (gs, bs1, ps) ⊆ args_to_set (gs, bs2, ps)"
using assms by (auto simp add: args_to_set_alt)
lemma args_to_set_subset3:
assumes "set ps1 ⊆ set ps2"
shows "args_to_set (gs, bs, ps1) ⊆ args_to_set (gs, bs, ps2)"
using assms unfolding args_to_set_alt by blast
subsubsection ‹Functions ‹count_const_lt_components›, ‹count_rem_comps› and ‹full_gb››
definition rem_comps_spec :: "('t, 'b::zero, 'c) pdata list ⇒ nat × 'd ⇒ bool"
where "rem_comps_spec bs data ⟷ (card (component_of_term ` Keys (fst ` set bs)) =
fst data + card (const_lt_component ` (fst ` set bs - {0}) - {None}))"
definition count_const_lt_components :: "('t, 'b::zero, 'c) pdata' list ⇒ nat"
where "count_const_lt_components hs = length (remdups (filter (λx. x ≠ None) (map (const_lt_component ∘ fst) hs)))"
definition count_rem_components :: "('t, 'b::zero, 'c) pdata' list ⇒ nat"
where "count_rem_components bs = length (remdups (map component_of_term (Keys_to_list (map fst bs)))) -
count_const_lt_components [b←bs . fst b ≠ 0]"
lemma count_const_lt_components_alt:
"count_const_lt_components hs = card (const_lt_component ` fst ` set hs - {None})"
by (simp add: count_const_lt_components_def card_set[symmetric] set_diff_eq image_comp del: not_None_eq)
lemma count_rem_components_alt:
"count_rem_components bs + card (const_lt_component ` (fst ` set bs - {0}) - {None}) =
card (component_of_term ` Keys (fst ` set bs))"
proof -
have eq: "fst ` {x ∈ set bs. fst x ≠ 0} = fst ` set bs - {0}" by fastforce
have "card (const_lt_component ` (fst ` set bs - {0}) - {None}) ≤ card (component_of_term ` Keys (fst ` set bs))"
by (rule card_const_lt_component_le, rule finite_imageI, fact finite_set)
thus ?thesis
by (simp add: count_rem_components_def card_set[symmetric] set_Keys_to_list count_const_lt_components_alt eq)
qed
lemma rem_comps_spec_count_rem_components: "rem_comps_spec bs (count_rem_components bs, data)"
by (simp only: rem_comps_spec_def fst_conv count_rem_components_alt)
definition full_gb :: "('t, 'b, 'c) pdata list ⇒ ('t, 'b::zero_neq_one, 'c::default) pdata list"
where "full_gb bs = map (λk. (monomial 1 (term_of_pair (0, k)), 0, default))
(remdups (map component_of_term (Keys_to_list (map fst bs))))"
lemma fst_set_full_gb:
"fst ` set (full_gb bs) = (λv. monomial 1 (term_of_pair (0, component_of_term v))) ` Keys (fst ` set bs)"
by (simp add: full_gb_def set_Keys_to_list image_comp)
lemma Keys_full_gb:
"Keys (fst ` set (full_gb bs)) = (λv. term_of_pair (0, component_of_term v)) ` Keys (fst ` set bs)"
by (auto simp add: fst_set_full_gb Keys_def image_image)
lemma pps_full_gb: "pp_of_term ` Keys (fst ` set (full_gb bs)) ⊆ {0}"
by (simp add: Keys_full_gb image_comp image_subset_iff term_simps)
lemma components_full_gb:
"component_of_term ` Keys (fst ` set (full_gb bs)) = component_of_term ` Keys (fst ` set bs)"
by (simp add: Keys_full_gb image_comp, rule image_cong, fact refl, simp add: term_simps)
lemma full_gb_is_full_pmdl: "is_full_pmdl (fst ` set (full_gb bs))"
for bs::"('t, 'b::field, 'c::default) pdata list"
proof (rule is_full_pmdlI_lt_finite)
from finite_set show "finite (fst ` set (full_gb bs))" by (rule finite_imageI)
next
fix k
assume "k ∈ component_of_term ` Keys (fst ` set (full_gb bs))"
then obtain v where "v ∈ Keys (fst ` set (full_gb bs))" and k: "k = component_of_term v" ..
from this(1) obtain b where "b ∈ fst ` set (full_gb bs)" and "v ∈ keys b" by (rule in_KeysE)
from this(1) obtain u where "u ∈ Keys (fst ` set bs)" and b: "b = monomial 1 (term_of_pair (0, component_of_term u))"
unfolding fst_set_full_gb ..
have lt: "lt b = term_of_pair (0, component_of_term u)" by (simp add: b lt_monomial)
from ‹v ∈ keys b› have v: "v = term_of_pair (0, component_of_term u)" by (simp add: b)
show "∃b∈fst ` set (full_gb bs). b ≠ 0 ∧ component_of_term (lt b) = k ∧ lp b = 0"
proof (intro bexI conjI)
show "b ≠ 0" by (simp add: b monomial_0_iff)
next
show "component_of_term (lt b) = k" by (simp add: lt term_simps k v)
next
show "lp b = 0" by (simp add: lt term_simps)
qed fact
qed
text ‹In fact, @{thm full_gb_is_full_pmdl} also holds if @{typ 'b} is no field.›
lemma full_gb_isGB: "is_Groebner_basis (fst ` set (full_gb bs))"
proof (rule Buchberger_criterion_finite)
from finite_set show "finite (fst ` set (full_gb bs))" by (rule finite_imageI)
next
fix p q :: "'t ⇒⇩0 'b"
assume "p ∈ fst ` set (full_gb bs)"
then obtain v where p: "p = monomial 1 (term_of_pair (0, component_of_term v))"
unfolding fst_set_full_gb ..
hence lt: "component_of_term (lt p) = component_of_term v" by (simp add: lt_monomial term_simps)
assume "q ∈ fst ` set (full_gb bs)"
then obtain u where q: "q = monomial 1 (term_of_pair (0, component_of_term u))"
unfolding fst_set_full_gb ..
hence lq: "component_of_term (lt q) = component_of_term u" by (simp add: lt_monomial term_simps)
assume "component_of_term (lt p) = component_of_term (lt q)"
hence "component_of_term v = component_of_term u" by (simp only: lt lq)
hence "p = q" by (simp only: p q)
moreover assume "p ≠ q"
ultimately show "(red (fst ` set (full_gb bs)))⇧*⇧* (spoly p q) 0" by (simp only:)
qed
subsubsection ‹Specification of the @{emph ‹completion›} parameter›
definition compl_struct :: "('t, 'b::field, 'c, 'd) complT ⇒ bool"
where "compl_struct compl ⟷
(∀gs bs ps sps data. sps ≠ [] ⟶ set sps ⊆ set ps ⟶
(∀d. dickson_grading d ⟶
dgrad_p_set_le d (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) (args_to_set (gs, bs, ps))) ∧
component_of_term ` Keys (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, ps)) ∧
0 ∉ fst ` set (fst (compl gs bs (ps -- sps) sps data)) ∧
(∀h∈set (fst (compl gs bs (ps -- sps) sps data)). ∀b∈set gs ∪ set bs. fst b ≠ 0 ⟶ ¬ lt (fst b) adds⇩t lt (fst h)))"
lemma compl_structI:
assumes "⋀d gs bs ps sps data. dickson_grading d ⟹ sps ≠ [] ⟹ set sps ⊆ set ps ⟹
dgrad_p_set_le d (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) (args_to_set (gs, bs, ps))"
assumes "⋀gs bs ps sps data. sps ≠ [] ⟹ set sps ⊆ set ps ⟹
component_of_term ` Keys (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, ps))"
assumes "⋀gs bs ps sps data. sps ≠ [] ⟹ set sps ⊆ set ps ⟹ 0 ∉ fst ` set (fst (compl gs bs (ps -- sps) sps data))"
assumes "⋀gs bs ps sps h b data. sps ≠ [] ⟹ set sps ⊆ set ps ⟹ h ∈ set (fst (compl gs bs (ps -- sps) sps data)) ⟹
b ∈ set gs ∪ set bs ⟹ fst b ≠ 0 ⟹ ¬ lt (fst b) adds⇩t lt (fst h)"
shows "compl_struct compl"
unfolding compl_struct_def using assms by auto
lemma compl_structD1:
assumes "compl_struct compl" and "dickson_grading d" and "sps ≠ []" and "set sps ⊆ set ps"
shows "dgrad_p_set_le d (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) (args_to_set (gs, bs, ps))"
using assms unfolding compl_struct_def by blast
lemma compl_structD2:
assumes "compl_struct compl" and "sps ≠ []" and "set sps ⊆ set ps"
shows "component_of_term ` Keys (fst ` (set (fst (compl gs bs (ps -- sps) sps data)))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, ps))"
using assms unfolding compl_struct_def by blast
lemma compl_structD3:
assumes "compl_struct compl" and "sps ≠ []" and "set sps ⊆ set ps"
shows "0 ∉ fst ` set (fst (compl gs bs (ps -- sps) sps data))"
using assms unfolding compl_struct_def by blast
lemma compl_structD4:
assumes "compl_struct compl" and "sps ≠ []" and "set sps ⊆ set ps"
and "h ∈ set (fst (compl gs bs (ps -- sps) sps data))" and "b ∈ set gs ∪ set bs" and "fst b ≠ 0"
shows "¬ lt (fst b) adds⇩t lt (fst h)"
using assms unfolding compl_struct_def by blast
definition struct_spec :: "('t, 'b::field, 'c, 'd) selT ⇒ ('t, 'b, 'c, 'd) apT ⇒ ('t, 'b, 'c, 'd) abT ⇒
('t, 'b, 'c, 'd) complT ⇒ bool"
where "struct_spec sel ap ab compl ⟷ (sel_spec sel ∧ ap_spec ap ∧ ab_spec ab ∧ compl_struct compl)"
lemma struct_specI:
assumes "sel_spec sel" and "ap_spec ap" and "ab_spec ab" and "compl_struct compl"
shows "struct_spec sel ap ab compl"
unfolding struct_spec_def using assms by (intro conjI)
lemma struct_specD1:
assumes "struct_spec sel ap ab compl"
shows "sel_spec sel"
using assms unfolding struct_spec_def by (elim conjE)
lemma struct_specD2:
assumes "struct_spec sel ap ab compl"
shows "ap_spec ap"
using assms unfolding struct_spec_def by (elim conjE)
lemma struct_specD3:
assumes "struct_spec sel ap ab compl"
shows "ab_spec ab"
using assms unfolding struct_spec_def by (elim conjE)
lemma struct_specD4:
assumes "struct_spec sel ap ab compl"
shows "compl_struct compl"
using assms unfolding struct_spec_def by (elim conjE)
lemmas struct_specD = struct_specD1 struct_specD2 struct_specD3 struct_specD4
definition compl_pmdl :: "('t, 'b::field, 'c, 'd) complT ⇒ bool"
where "compl_pmdl compl ⟷
(∀gs bs ps sps data. is_Groebner_basis (fst ` set gs) ⟶ sps ≠ [] ⟶ set sps ⊆ set ps ⟶
unique_idx (gs @ bs) data ⟶
fst ` (set (fst (compl gs bs (ps -- sps) sps data))) ⊆ pmdl (args_to_set (gs, bs, ps)))"
lemma compl_pmdlI:
assumes "⋀gs bs ps sps data. is_Groebner_basis (fst ` set gs) ⟹ sps ≠ [] ⟹ set sps ⊆ set ps ⟹
unique_idx (gs @ bs) data ⟹
fst ` (set (fst (compl gs bs (ps -- sps) sps data))) ⊆ pmdl (args_to_set (gs, bs, ps))"
shows "compl_pmdl compl"
unfolding compl_pmdl_def using assms by blast
lemma compl_pmdlD:
assumes "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)"
and "sps ≠ []" and "set sps ⊆ set ps" and "unique_idx (gs @ bs) data"
shows "fst ` (set (fst (compl gs bs (ps -- sps) sps data))) ⊆ pmdl (args_to_set (gs, bs, ps))"
using assms unfolding compl_pmdl_def by blast
definition compl_conn :: "('t, 'b::field, 'c, 'd) complT ⇒ bool"
where "compl_conn compl ⟷
(∀d m gs bs ps sps p q data. dickson_grading d ⟶ fst ` set gs ⊆ dgrad_p_set d m ⟶
is_Groebner_basis (fst ` set gs) ⟶ fst ` set bs ⊆ dgrad_p_set d m ⟶
set ps ⊆ set bs × (set gs ∪ set bs) ⟶ sps ≠ [] ⟶ set sps ⊆ set ps ⟶
unique_idx (gs @ bs) data ⟶ (p, q) ∈ set sps ⟶ fst p ≠ 0 ⟶ fst q ≠ 0 ⟶
crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps data))) (fst p) (fst q))"
text ‹Informally, ‹compl_conn compl› means that, for suitable arguments ‹gs›, ‹bs›, ‹ps› and ‹sps›,
the value of ‹compl gs bs ps sps› is a list ‹hs› such that the critical pairs of all elements in
‹sps› can be connected modulo ‹set gs ∪ set bs ∪ set hs›.›
lemma compl_connI:
assumes "⋀d m gs bs ps sps p q data. dickson_grading d ⟹ fst ` set gs ⊆ dgrad_p_set d m ⟹
is_Groebner_basis (fst ` set gs) ⟹ fst ` set bs ⊆ dgrad_p_set d m ⟹
set ps ⊆ set bs × (set gs ∪ set bs) ⟹ sps ≠ [] ⟹ set sps ⊆ set ps ⟹
unique_idx (gs @ bs) data ⟹ (p, q) ∈ set sps ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps data))) (fst p) (fst q)"
shows "compl_conn compl"
unfolding compl_conn_def using assms by presburger
lemma compl_connD:
assumes "compl_conn compl" and "dickson_grading d" and "fst ` set gs ⊆ dgrad_p_set d m"
and "is_Groebner_basis (fst ` set gs)" and "fst ` set bs ⊆ dgrad_p_set d m"
and "set ps ⊆ set bs × (set gs ∪ set bs)" and "sps ≠ []" and "set sps ⊆ set ps"
and "unique_idx (gs @ bs) data" and "(p, q) ∈ set sps" and "fst p ≠ 0" and "fst q ≠ 0"
shows "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps data))) (fst p) (fst q)"
using assms unfolding compl_conn_def Un_assoc by blast
subsubsection ‹Function ‹gb_schema_dummy››
definition (in -) add_indices :: "(('a, 'b, 'c) pdata' list × 'd) ⇒ (nat × 'd) ⇒ (('a, 'b, 'c) pdata list × nat × 'd)"
where [code del]: "add_indices ns data =
(map_idx (λh i. (fst h, i, snd h)) (fst ns) (fst data), fst data + length (fst ns), snd ns)"
lemma (in -) add_indices_code [code]:
"add_indices (ns, data) (n, data') = (map_idx (λ(h, d) i. (h, i, d)) ns n, n + length ns, data)"
by (simp add: add_indices_def case_prod_beta')
lemma fst_add_indices: "map fst (fst (add_indices ns data')) = map fst (fst ns)"
by (simp add: add_indices_def map_map_idx map_idx_no_idx)
corollary fst_set_add_indices: "fst ` set (fst (add_indices ns data')) = fst ` set (fst ns)"
using fst_add_indices by (metis set_map)
lemma in_set_add_indicesE:
assumes "f ∈ set (fst (add_indices aux data))"
obtains i where "i < length (fst aux)" and "f = (fst ((fst aux) ! i), fst data + i, snd ((fst aux) ! i))"
proof -
let ?hs = "fst (add_indices aux data)"
from assms obtain i where "i < length ?hs" and "f = ?hs ! i" by (metis in_set_conv_nth)
from this(1) have "i < length (fst aux)" by (simp add: add_indices_def)
hence "?hs ! i = (fst ((fst aux) ! i), fst data + i, snd ((fst aux) ! i))"
unfolding add_indices_def fst_conv by (rule map_idx_nth)
hence "f = (fst ((fst aux) ! i), fst data + i, snd ((fst aux) ! i))" by (simp add: ‹f = ?hs ! i›)
with ‹i < length (fst aux)› show ?thesis ..
qed
definition gb_schema_aux_term1 :: "((('t, 'b::field, 'c) pdata list × ('t, 'b, 'c) pdata_pair list) ×
(('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair list)) set"
where "gb_schema_aux_term1 = {(a, b::('t, 'b, 'c) pdata list). (fst ` set a) ⊐p (fst ` set b)} <*lex*>
(measure (card ∘ set))"
definition gb_schema_aux_term2 ::
"('a ⇒ nat) ⇒ ('t, 'b::field, 'c) pdata list ⇒ ((('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair list) ×
(('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair list)) set"
where "gb_schema_aux_term2 d gs = {(a, b). dgrad_p_set_le d (args_to_set (gs, a)) (args_to_set (gs, b)) ∧
component_of_term ` Keys (args_to_set (gs, a)) ⊆ component_of_term ` Keys (args_to_set (gs, b))}"
definition gb_schema_aux_term where "gb_schema_aux_term d gs = gb_schema_aux_term1 ∩ gb_schema_aux_term2 d gs"
text ‹@{const gb_schema_aux_term} is needed for proving termination of function ‹gb_schema_aux›.›
lemma gb_schema_aux_term1_wf_on:
assumes "dickson_grading d" and "finite K"
shows "wfp_on (λx y. (x, y) ∈ gb_schema_aux_term1)
{x::(('t, 'b, 'c) pdata list) × ((('t, 'b::field, 'c) pdata_pair list)).
args_to_set (gs, x) ⊆ dgrad_p_set d m ∧ component_of_term ` Keys (args_to_set (gs, x)) ⊆ K}"
proof (rule wfp_onI_min)
let ?B = "dgrad_p_set d m"
let ?A = "{x::(('t, 'b, 'c) pdata list) × ((('t, 'b, 'c) pdata_pair list)).
args_to_set (gs, x) ⊆ ?B ∧ component_of_term ` Keys (args_to_set (gs, x)) ⊆ K}"
let ?C = "Pow ?B ∩ {F. component_of_term ` Keys F ⊆ K}"
have A_sub_Pow: "(image fst) ` set ` fst ` ?A ⊆ ?C"
proof
fix x
assume "x ∈ (image fst) ` set ` fst ` ?A"
then obtain x1 where "x1 ∈ set ` fst ` ?A" and x: "x = fst ` x1" by auto
from this(1) obtain x2 where "x2 ∈ fst ` ?A" and x1: "x1 = set x2" by auto
from this(1) obtain x3 where "x3 ∈ ?A" and x2: "x2 = fst x3" by auto
from this(1) have "args_to_set (gs, x3) ⊆ ?B" and "component_of_term ` Keys (args_to_set (gs, x3)) ⊆ K"
by simp_all
thus "x ∈ ?C" by (simp add: args_to_set_def x x1 x2 image_Un Keys_Un)
qed
fix x Q
assume "x ∈ Q" and "Q ⊆ ?A"
have Q_sub_A: "(image fst) ` set ` fst ` Q ⊆ (image fst) ` set ` fst ` ?A"
by ((rule image_mono)+, fact)
from assms have "wfp_on (⊐p) ?C" by (rule red_supset_wf_on)
moreover have "fst ` set (fst x) ∈ (image fst) ` set ` fst ` Q"
by (rule, fact refl, rule, fact refl, rule, fact refl, simp add: ‹x ∈ Q›)
moreover from Q_sub_A A_sub_Pow have "(image fst) ` set ` fst ` Q ⊆ ?C" by (rule subset_trans)
ultimately obtain z1 where "z1 ∈ (image fst) ` set ` fst ` Q"
and 2: "⋀y. y ⊐p z1 ⟹ y ∉ (image fst) ` set ` fst ` Q" by (rule wfp_onE_min, auto)
from this(1) obtain x1 where "x1 ∈ Q" and z1: "z1 = fst ` set (fst x1)" by auto
let ?Q2 = "{q ∈ Q. fst ` set (fst q) = z1}"
have "snd x1 ∈ snd ` ?Q2" by (rule, fact refl, simp add: ‹x1 ∈ Q› z1)
with wf_measure obtain z2 where "z2 ∈ snd ` ?Q2"
and 3: "⋀y. (y, z2) ∈ measure (card ∘ set) ⟹ y ∉ snd ` ?Q2"
by (rule wfE_min, blast)
from this(1) obtain z where "z ∈ ?Q2" and z2: "z2 = snd z" ..
from this(1) have "z ∈ Q" and eq1: "fst ` set (fst z) = z1" by blast+
from this(1) show "∃z∈Q. ∀y∈?A. (y, z) ∈ gb_schema_aux_term1 ⟶ y ∉ Q"
proof
show "∀y∈?A. (y, z) ∈ gb_schema_aux_term1 ⟶ y ∉ Q"
proof (intro ballI impI)
fix y
assume "y ∈ ?A"
assume "(y, z) ∈ gb_schema_aux_term1"
hence "(fst ` set (fst y) ⊐p z1 ∨ (fst y = fst z ∧ (snd y, z2) ∈ measure (card ∘ set)))"
by (simp add: gb_schema_aux_term1_def eq1[symmetric] z2 in_lex_prod_alt)
thus "y ∉ Q"
proof (elim disjE conjE)
assume "fst ` set (fst y) ⊐p z1"
hence "fst ` set (fst y) ∉ (image fst) ` set ` fst ` Q" by (rule 2)
thus ?thesis by auto
next
assume "(snd y, z2) ∈ measure (card ∘ set)"
hence "snd y ∉ snd ` ?Q2" by (rule 3)
hence "y ∉ ?Q2" by blast
moreover assume "fst y = fst z"
ultimately show ?thesis by (simp add: eq1)
qed
qed
qed
qed
lemma gb_schema_aux_term_wf:
assumes "dickson_grading d"
shows "wf (gb_schema_aux_term d gs)"
proof (rule wfI_min)
fix x::"(('t, 'b, 'c) pdata list) × (('t, 'b, 'c) pdata_pair list)" and Q
assume "x ∈ Q"
let ?A = "args_to_set (gs, x)"
have "finite ?A" by (simp add: args_to_set_def)
then obtain m where A: "?A ⊆ dgrad_p_set d m" by (rule dgrad_p_set_exhaust)
define K where "K = component_of_term ` Keys ?A"
from ‹finite ?A› have "finite K" unfolding K_def by (rule finite_imp_finite_component_Keys)
let ?B = "dgrad_p_set d m"
let ?Q = "{q ∈ Q. args_to_set (gs, q) ⊆ ?B ∧ component_of_term ` Keys (args_to_set (gs, q)) ⊆ K}"
from assms ‹finite K› have "wfp_on (λx y. (x, y) ∈ gb_schema_aux_term1)
{x. args_to_set (gs, x) ⊆ ?B ∧ component_of_term ` Keys (args_to_set (gs, x)) ⊆ K}"
by (rule gb_schema_aux_term1_wf_on)
moreover from ‹x ∈ Q› A have "x ∈ ?Q" by (simp add: K_def)
moreover have "?Q ⊆ {x. args_to_set (gs, x) ⊆ ?B ∧ component_of_term ` Keys (args_to_set (gs, x)) ⊆ K}" by auto
ultimately obtain z where "z ∈ ?Q"
and *: "⋀y. (y, z) ∈ gb_schema_aux_term1 ⟹ y ∉ ?Q" by (rule wfp_onE_min, blast)
from this(1) have "z ∈ Q" and a: "args_to_set (gs, z) ⊆ ?B" and b: "component_of_term ` Keys (args_to_set (gs, z)) ⊆ K"
by simp_all
from this(1) show "∃z∈Q. ∀y. (y, z) ∈ gb_schema_aux_term d gs ⟶ y ∉ Q"
proof
show "∀y. (y, z) ∈ gb_schema_aux_term d gs ⟶ y ∉ Q"
proof (intro allI impI)
fix y
assume "(y, z) ∈ gb_schema_aux_term d gs"
hence "(y, z) ∈ gb_schema_aux_term1" and "(y, z) ∈ gb_schema_aux_term2 d gs"
by (simp_all add: gb_schema_aux_term_def)
from this(2) have "dgrad_p_set_le d (args_to_set (gs, y)) (args_to_set (gs, z))"
and comp_sub: "component_of_term ` Keys (args_to_set (gs, y)) ⊆ component_of_term ` Keys (args_to_set (gs, z))"
by (simp_all add: gb_schema_aux_term2_def)
from this(1) ‹args_to_set (gs, z) ⊆ ?B› have "args_to_set (gs, y) ⊆ ?B"
by (rule dgrad_p_set_le_dgrad_p_set)
moreover from comp_sub b have "component_of_term ` Keys (args_to_set (gs, y)) ⊆ K"
by (rule subset_trans)
moreover from ‹(y, z) ∈ gb_schema_aux_term1› have "y ∉ ?Q" by (rule *)
ultimately show "y ∉ Q" by simp
qed
qed
qed
lemma dgrad_p_set_le_args_to_set_ab:
assumes "dickson_grading d" and "ap_spec ap" and "ab_spec ab" and "compl_struct compl"
assumes "sps ≠ []" and "set sps ⊆ set ps" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)"
shows "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))"
(is "dgrad_p_set_le _ ?l ?r")
proof -
have "dgrad_p_set_le d ?l
(fst ` (set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs))"
by (rule dgrad_p_set_le_subset, rule args_to_set_subset[OF assms(2, 3)])
also have "dgrad_p_set_le d ... ?r" unfolding image_Un
proof (intro dgrad_p_set_leI_Un)
show "dgrad_p_set_le d (fst ` set gs) (args_to_set (gs, bs, ps))"
by (rule dgrad_p_set_le_subset, auto simp add: args_to_set_def)
next
show "dgrad_p_set_le d (fst ` set bs) (args_to_set (gs, bs, ps))"
by (rule dgrad_p_set_le_subset, auto simp add: args_to_set_def)
next
show "dgrad_p_set_le d (fst ` fst ` set (ps -- sps)) (args_to_set (gs, bs, ps))"
by (rule dgrad_p_set_le_subset, auto simp add: args_to_set_def set_diff_list)
next
show "dgrad_p_set_le d (fst ` snd ` set (ps -- sps)) (args_to_set (gs, bs, ps))"
by (rule dgrad_p_set_le_subset, auto simp add: args_to_set_def set_diff_list)
next
from assms(4, 1, 5, 6) show "dgrad_p_set_le d (fst ` set hs) (args_to_set (gs, bs, ps))"
unfolding assms(7) fst_set_add_indices by (rule compl_structD1)
qed
finally show ?thesis .
qed
corollary dgrad_p_set_le_args_to_set_struct:
assumes "dickson_grading d" and "struct_spec sel ap ab compl" and "ps ≠ []"
assumes "sps = sel gs bs ps data" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)"
shows "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))"
proof -
from assms(2) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab"
and compl: "compl_struct compl" by (rule struct_specD)+
from sel assms(3) have "sps ≠ []" and "set sps ⊆ set ps"
unfolding assms(4) by (rule sel_specD1, rule sel_specD2)
from assms(1) ap ab compl this assms(5) show ?thesis by (rule dgrad_p_set_le_args_to_set_ab)
qed
lemma components_subset_ab:
assumes "ap_spec ap" and "ab_spec ab" and "compl_struct compl"
assumes "sps ≠ []" and "set sps ⊆ set ps" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)"
shows "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) ⊆
component_of_term ` Keys (args_to_set (gs, bs, ps))" (is "?l ⊆ ?r")
proof -
have "?l ⊆ component_of_term ` Keys (fst ` (set gs ∪ set bs ∪ fst ` set (ps -- sps) ∪ snd ` set (ps -- sps) ∪ set hs))"
by (rule image_mono, rule Keys_mono, rule args_to_set_subset[OF assms(1, 2)])
also have "... ⊆ ?r" unfolding image_Un Keys_Un Un_subset_iff
proof (intro conjI)
show "component_of_term ` Keys (fst ` set gs) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))"
by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_def)
next
show "component_of_term ` Keys (fst ` set bs) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))"
by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_def)
next
show "component_of_term ` Keys (fst ` fst ` set (ps -- sps)) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))"
by (rule image_mono, rule Keys_mono, auto simp add: set_diff_list args_to_set_def)
next
show "component_of_term ` Keys (fst ` snd ` set (ps -- sps)) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))"
by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_def set_diff_list)
next
from assms(3, 4, 5) show "component_of_term ` Keys (fst ` set hs) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))"
unfolding assms(6) fst_set_add_indices by (rule compl_structD2)
qed
finally show ?thesis .
qed
corollary components_subset_struct:
assumes "struct_spec sel ap ab compl" and "ps ≠ []"
assumes "sps = sel gs bs ps data" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)"
shows "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) ⊆
component_of_term ` Keys (args_to_set (gs, bs, ps))"
proof -
from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab"
and compl: "compl_struct compl" by (rule struct_specD)+
from sel assms(2) have "sps ≠ []" and "set sps ⊆ set ps"
unfolding assms(3) by (rule sel_specD1, rule sel_specD2)
from ap ab compl this assms(4) show ?thesis by (rule components_subset_ab)
qed
corollary components_struct:
assumes "struct_spec sel ap ab compl" and "ps ≠ []" and "set ps ⊆ set bs × (set gs ∪ set bs)"
assumes "sps = sel gs bs ps data" and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)"
shows "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) =
component_of_term ` Keys (args_to_set (gs, bs, ps))" (is "?l = ?r")
proof
from assms(1, 2, 4, 5) show "?l ⊆ ?r" by (rule components_subset_struct)
next
from assms(1) have ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl"
by (rule struct_specD)+
from ap ab assms(3)
have sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))"
by (rule subset_Times_ap)
show "?r ⊆ ?l"
by (simp add: args_to_set_subset_Times[OF sub] args_to_set_subset_Times[OF assms(3)] ab_specD1[OF ab],
rule image_mono, rule Keys_mono, blast)
qed
lemma struct_spec_red_supset:
assumes "struct_spec sel ap ab compl" and "ps ≠ []" and "sps = sel gs bs ps data"
and "hs = fst (add_indices (compl gs bs (ps -- sps) sps data) data)" and "hs ≠ []"
shows "(fst ` set (ab gs bs hs data')) ⊐p (fst ` set bs)"
proof -
from assms(5) have "set hs ≠ {}" by simp
then obtain h' where "h' ∈ set hs" by fastforce
let ?h = "fst h'"
let ?m = "monomial (lc ?h) (lt ?h)"
from ‹h' ∈ set hs› have h_in: "?h ∈ fst ` set hs" by simp
hence "?h ∈ fst ` set (fst (compl gs bs (ps -- sps) sps data))"
by (simp only: assms(4) fst_set_add_indices)
then obtain h'' where h''_in: "h'' ∈ set (fst (compl gs bs (ps -- sps) sps data))"
and "?h = fst h''" ..
from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab"
and compl: "compl_struct compl" by (rule struct_specD)+
from sel assms(2) have "sps ≠ []" and "set sps ⊆ set ps" unfolding assms(3)
by (rule sel_specD1, rule sel_specD2)
from h_in compl_structD3[OF compl this] have "?h ≠ 0" unfolding assms(4) fst_set_add_indices
by metis
show ?thesis
proof (simp add: ab_specD1[OF ab] image_Un, rule)
fix q
assume "is_red (fst ` set bs) q"
moreover have "fst ` set bs ⊆ fst ` set bs ∪ fst ` set hs" by simp
ultimately show "is_red (fst ` set bs ∪ fst ` set hs) q" by (rule is_red_subset)
next
from ‹?h ≠ 0› have "lc ?h ≠ 0" by (rule lc_not_0)
moreover have "?h ∈ {?h}" ..
ultimately have "is_red {?h} ?m" using ‹?h ≠ 0› adds_term_refl by (rule is_red_monomialI)
moreover have "{?h} ⊆ fst ` set bs ∪ fst ` set hs" using h_in by simp
ultimately show "is_red (fst ` set bs ∪ fst ` set hs) ?m" by (rule is_red_subset)
next
show "¬ is_red (fst ` set bs) ?m"
proof
assume "is_red (fst ` set bs) ?m"
then obtain b' where "b' ∈ fst ` set bs" and "b' ≠ 0" and "lt b' adds⇩t lt ?h"
by (rule is_red_monomialE)
from this(1) obtain b where "b ∈ set bs" and b': "b' = fst b" ..
from this(1) have "b ∈ set gs ∪ set bs" by simp
from ‹b' ≠ 0› have "fst b ≠ 0" by (simp add: b')
with compl ‹sps ≠ []› ‹set sps ⊆ set ps› h''_in ‹b ∈ set gs ∪ set bs› have "¬ lt (fst b) adds⇩t lt ?h"
unfolding ‹?h = fst h''› by (rule compl_structD4)
from this ‹lt b' adds⇩t lt ?h› show False by (simp add: b')
qed
qed
qed
lemma unique_idx_append:
assumes "unique_idx gs data" and "(hs, data') = add_indices aux data"
shows "unique_idx (gs @ hs) data'"
proof -
from assms(2) have hs: "hs = fst (add_indices aux data)" and data': "data' = snd (add_indices aux data)"
by (metis fst_conv, metis snd_conv)
have len: "length hs = length (fst aux)" by (simp add: hs add_indices_def)
have eq: "fst data' = fst data + length hs" by (simp add: data' add_indices_def hs)
show ?thesis
proof (rule unique_idxI)
fix f g
assume "f ∈ set (gs @ hs)" and "g ∈ set (gs @ hs)"
hence d1: "f ∈ set gs ∪ set hs" and d2: "g ∈ set gs ∪ set hs" by simp_all
assume id_eq: "fst (snd f) = fst (snd g)"
from d1 show "f = g"
proof
assume "f ∈ set gs"
from d2 show ?thesis
proof
assume "g ∈ set gs"
from assms(1) ‹f ∈ set gs› this id_eq show ?thesis by (rule unique_idxD1)
next
assume "g ∈ set hs"
then obtain j where "g = (fst (fst aux ! j), fst data + j, snd (fst aux ! j))" unfolding hs
by (rule in_set_add_indicesE)
hence "fst (snd g) = fst data + j" by simp
moreover from assms(1) ‹f ∈ set gs› have "fst (snd f) < fst data"
by (rule unique_idxD2)
ultimately show ?thesis by (simp add: id_eq)
qed
next
assume "f ∈ set hs"
then obtain i where f: "f = (fst (fst aux ! i), fst data + i, snd (fst aux ! i))" unfolding hs
by (rule in_set_add_indicesE)
hence *: "fst (snd f) = fst data + i" by simp
from d2 show ?thesis
proof
assume "g ∈ set gs"
with assms(1) have "fst (snd g) < fst data" by (rule unique_idxD2)
with * show ?thesis by (simp add: id_eq)
next
assume "g ∈ set hs"
then obtain j where g: "g = (fst (fst aux ! j), fst data + j, snd (fst aux ! j))" unfolding hs
by (rule in_set_add_indicesE)
hence "fst (snd g) = fst data + j" by simp
with * have "i = j" by (simp add: id_eq)
thus ?thesis by (simp add: f g)
qed
qed
next
fix f
assume "f ∈ set (gs @ hs)"
hence "f ∈ set gs ∪ set hs" by simp
thus "fst (snd f) < fst data'"
proof
assume "f ∈ set gs"
with assms(1) have "fst (snd f) < fst data" by (rule unique_idxD2)
also have "... ≤ fst data'" by (simp add: eq)
finally show ?thesis .
next
assume "f ∈ set hs"
then obtain i where "i < length (fst aux)"
and "f = (fst (fst aux ! i), fst data + i, snd (fst aux ! i))" unfolding hs
by (rule in_set_add_indicesE)
from this(2) have "fst (snd f) = fst data + i" by simp
also from ‹i < length (fst aux)› have "... < fst data + length (fst aux)" by simp
finally show ?thesis by (simp only: eq len)
qed
qed
qed
corollary unique_idx_ab:
assumes "ab_spec ab" and "unique_idx (gs @ bs) data" and "(hs, data') = add_indices aux data"
shows "unique_idx (gs @ ab gs bs hs data') data'"
proof -
from assms(2, 3) have "unique_idx ((gs @ bs) @ hs) data'" by (rule unique_idx_append)
thus ?thesis by (simp add: unique_idx_def ab_specD1[OF assms(1)])
qed
lemma rem_comps_spec_struct:
assumes "struct_spec sel ap ab compl" and "rem_comps_spec (gs @ bs) data" and "ps ≠ []"
and "set ps ⊆ (set bs) × (set gs ∪ set bs)" and "sps = sel gs bs ps (snd data)"
and "aux = compl gs bs (ps -- sps) sps (snd data)" and "(hs, data') = add_indices aux (snd data)"
shows "rem_comps_spec (gs @ ab gs bs hs data') (fst data - count_const_lt_components (fst aux), data')"
proof -
from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl"
by (rule struct_specD)+
from ap ab assms(4)
have sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))"
by (rule subset_Times_ap)
have hs: "hs = fst (add_indices aux (snd data))" by (simp add: assms(7)[symmetric])
from sel assms(3) have "sps ≠ []" and "set sps ⊆ set ps" unfolding assms(5)
by (rule sel_specD1, rule sel_specD2)
have eq0: "fst ` set (fst aux) - {0} = fst ` set (fst aux)"
by (rule Diff_triv, simp add: Int_insert_right assms(6), rule compl_structD3, fact+)
have "component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data')) =
component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data'))"
by (simp add: args_to_set_subset_Times[OF sub] image_Un)
also from assms(1, 3, 4, 5) hs
have "... = component_of_term ` Keys (args_to_set (gs, bs, ps))" unfolding assms(6)
by (rule components_struct)
also have "... = component_of_term ` Keys (fst ` set (gs @ bs))"
by (simp add: args_to_set_subset_Times[OF assms(4)] image_Un)
finally have eq: "component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data')) =
component_of_term ` Keys (fst ` set (gs @ bs))" .
from assms(2)
have eq2: "card (component_of_term ` Keys (fst ` set (gs @ bs))) =
fst data + card (const_lt_component ` (fst ` set (gs @ bs) - {0}) - {None})" (is "?a = _ + ?b")
by (simp only: rem_comps_spec_def)
have eq3: "card (const_lt_component ` (fst ` set (gs @ ab gs bs hs data') - {0}) - {None}) =
?b + count_const_lt_components (fst aux)" (is "?c = _")
proof (simp add: ab_specD1[OF ab] image_Un Un_assoc[symmetric] Un_Diff count_const_lt_components_alt
hs fst_set_add_indices eq0, rule card_Un_disjoint)
show "finite (const_lt_component ` (fst ` set gs - {0}) - {None} ∪ (const_lt_component ` (fst ` set bs - {0}) - {None}))"
by (intro finite_UnI finite_Diff finite_imageI finite_set)
next
show "finite (const_lt_component ` fst ` set (fst aux) - {None})"
by (rule finite_Diff, intro finite_imageI, fact finite_set)
next
have "(const_lt_component ` (fst ` (set gs ∪ set bs) - {0}) - {None}) ∩
(const_lt_component ` fst ` set (fst aux) - {None}) =
(const_lt_component ` (fst ` (set gs ∪ set bs) - {0}) ∩
const_lt_component ` fst ` set (fst aux)) - {None}" by blast
also have "... = {}"
proof (simp, rule, simp, elim conjE)
fix k
assume "k ∈ const_lt_component ` (fst ` (set gs ∪ set bs) - {0})"
then obtain b where "b ∈ set gs ∪ set bs" and "fst b ≠ 0" and k1: "k = const_lt_component (fst b)"
by blast
assume "k ∈ const_lt_component ` fst ` set (fst aux)"
then obtain h where "h ∈ set (fst aux)" and k2: "k = const_lt_component (fst h)" by blast
show "k = None"
proof (rule ccontr, simp, elim exE)
fix k'
assume "k = Some k'"
hence "lp (fst b) = 0" and "component_of_term (lt (fst b)) = k'" unfolding k1
by (rule const_lt_component_SomeD1, rule const_lt_component_SomeD2)
moreover from ‹k = Some k'› have "lp (fst h) = 0" and "component_of_term (lt (fst h)) = k'"
unfolding k2 by (rule const_lt_component_SomeD1, rule const_lt_component_SomeD2)
ultimately have "lt (fst b) adds⇩t lt (fst h)" by (simp add: adds_term_def)
moreover from compl ‹sps ≠ []› ‹set sps ⊆ set ps› ‹h ∈ set (fst aux)› ‹b ∈ set gs ∪ set bs› ‹fst b ≠ 0›
have "¬ lt (fst b) adds⇩t lt (fst h)" unfolding assms(6) by (rule compl_structD4)
ultimately show False by simp
qed
qed
finally show "(const_lt_component ` (fst ` set gs - {0}) - {None} ∪ (const_lt_component ` (fst ` set bs - {0}) - {None})) ∩
(const_lt_component ` fst ` set (fst aux) - {None}) = {}" by (simp only: Un_Diff image_Un)
qed
have "?c ≤ ?a" unfolding eq[symmetric]
by (rule card_const_lt_component_le, rule finite_imageI, fact finite_set)
hence le: "count_const_lt_components (fst aux) ≤ fst data" by (simp only: eq2 eq3)
show ?thesis by (simp only: rem_comps_spec_def eq eq2 eq3, simp add: le)
qed
lemma pmdl_struct:
assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)"
and "ps ≠ []" and "set ps ⊆ (set bs) × (set gs ∪ set bs)" and "unique_idx (gs @ bs) (snd data)"
and "sps = sel gs bs ps (snd data)" and "aux = compl gs bs (ps -- sps) sps (snd data)"
and "(hs, data') = add_indices aux (snd data)"
shows "pmdl (fst ` set (gs @ ab gs bs hs data')) = pmdl (fst ` set (gs @ bs))"
proof -
have hs: "hs = fst (add_indices aux (snd data))" by (simp add: assms(9)[symmetric])
from assms(1) have sel: "sel_spec sel" and ab: "ab_spec ab" by (rule struct_specD)+
have eq: "fst ` (set gs ∪ set (ab gs bs hs data')) = fst ` (set gs ∪ set bs) ∪ fst ` set hs"
by (auto simp add: ab_specD1[OF ab])
show ?thesis
proof (simp add: eq, rule)
show "pmdl (fst ` (set gs ∪ set bs) ∪ fst ` set hs) ⊆ pmdl (fst ` (set gs ∪ set bs))"
proof (rule pmdl.span_subset_spanI, simp only: Un_subset_iff, rule)
show "fst ` (set gs ∪ set bs) ⊆ pmdl (fst ` (set gs ∪ set bs))"
by (fact pmdl.span_superset)
next
from sel assms(4) have "sps ≠ []" and "set sps ⊆ set ps"
unfolding assms(7) by (rule sel_specD1, rule sel_specD2)
with assms(2, 3) have "fst ` set hs ⊆ pmdl (args_to_set (gs, bs, ps))"
unfolding hs assms(8) fst_set_add_indices using assms(6) by (rule compl_pmdlD)
thus "fst ` set hs ⊆ pmdl (fst ` (set gs ∪ set bs))"
by (simp only: args_to_set_subset_Times[OF assms(5)] image_Un)
qed
next
show "pmdl (fst ` (set gs ∪ set bs)) ⊆ pmdl (fst ` (set gs ∪ set bs) ∪ fst ` set hs)"
by (rule pmdl.span_mono, blast)
qed
qed
lemma discarded_subset:
assumes "ab_spec ab"
and "D' = D ∪ (set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) -⇩p set (ap gs bs (ps -- sps) hs data'))"
and "set ps ⊆ set bs × (set gs ∪ set bs)" and "D ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)"
shows "D' ⊆ (set gs ∪ set (ab gs bs hs data')) × (set gs ∪ set (ab gs bs hs data'))"
proof -
from assms(1) have eq: "set (ab gs bs hs data') = set bs ∪ set hs" by (rule ab_specD1)
from assms(4) have "D ⊆ (set gs ∪ (set bs ∪ set hs)) × (set gs ∪ (set bs ∪ set hs))" by fastforce
moreover have "set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) -⇩p set (ap gs bs (ps -- sps) hs data') ⊆
(set gs ∪ (set bs ∪ set hs)) × (set gs ∪ (set bs ∪ set hs))" (is "?l ⊆ ?r")
proof (rule subset_trans)
show "?l ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)"
by (simp add: minus_pairs_def)
next
have "set hs × (set gs ∪ set bs ∪ set hs) ⊆ ?r" by fastforce
moreover have "set (ps -- sps) ⊆ ?r"
proof (rule subset_trans)
show "set (ps -- sps) ⊆ set ps" by (auto simp: set_diff_list)
next
from assms(3) show "set ps ⊆ ?r" by fastforce
qed
ultimately show "set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) ⊆ ?r" by (rule Un_least)
qed
ultimately show ?thesis unfolding eq assms(2) by (rule Un_least)
qed
lemma compl_struct_disjoint:
assumes "compl_struct compl" and "sps ≠ []" and "set sps ⊆ set ps"
shows "fst ` set (fst (compl gs bs (ps -- sps) sps data)) ∩ fst ` (set gs ∪ set bs) = {}"
proof (rule, rule)
fix x
assume "x ∈ fst ` set (fst (compl gs bs (ps -- sps) sps data)) ∩ fst ` (set gs ∪ set bs)"
hence x_in: "x ∈ fst ` set (fst (compl gs bs (ps -- sps) sps data))" and "x ∈ fst ` (set gs ∪ set bs)"
by simp_all
from x_in obtain h where h_in: "h ∈ set (fst (compl gs bs (ps -- sps) sps data))" and x1: "x = fst h" ..
from compl_structD3[OF assms, of gs bs data] x_in have "x ≠ 0" by auto
from ‹x ∈ fst ` (set gs ∪ set bs)› obtain b where b_in: "b ∈ set gs ∪ set bs" and x2: "x = fst b" ..
from ‹x ≠ 0› have "fst b ≠ 0" by (simp add: x2)
with assms h_in b_in have "¬ lt (fst b) adds⇩t lt (fst h)" by (rule compl_structD4)
hence "¬ lt x adds⇩t lt x" by (simp add: x1[symmetric] x2)
from this adds_term_refl show "x ∈ {}" ..
qed simp
context
fixes sel::"('t, 'b::field, 'c::default, 'd) selT" and ap::"('t, 'b, 'c, 'd) apT"
and ab::"('t, 'b, 'c, 'd) abT" and compl::"('t, 'b, 'c, 'd) complT"
and gs::"('t, 'b, 'c) pdata list"
begin
function (domintros) gb_schema_dummy :: "nat × nat × 'd ⇒ ('t, 'b, 'c) pdata_pair set ⇒
('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒
(('t, 'b, 'c) pdata list × ('t, 'b, 'c) pdata_pair set)"
where
"gb_schema_dummy data D bs ps =
(if ps = [] then
(gs @ bs, D)
else
(let sps = sel gs bs ps (snd data); ps0 = ps -- sps; aux = compl gs bs ps0 sps (snd data);
remcomps = fst (data) - count_const_lt_components (fst aux) in
(if remcomps = 0 then
(full_gb (gs @ bs), D)
else
let (hs, data') = add_indices aux (snd data) in
gb_schema_dummy (remcomps, data')
(D ∪ ((set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)) -⇩p set (ap gs bs ps0 hs data')))
(ab gs bs hs data') (ap gs bs ps0 hs data')
)
)
)"
by pat_completeness auto
lemma gb_schema_dummy_domI1: "gb_schema_dummy_dom (data, D, bs, [])"
by (rule gb_schema_dummy.domintros, simp)
lemma gb_schema_dummy_domI2:
assumes "struct_spec sel ap ab compl"
shows "gb_schema_dummy_dom (data, D, args)"
proof -
from assms have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+
from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" ..
let ?R = "(gb_schema_aux_term d gs)"
from dg have "wf ?R" by (rule gb_schema_aux_term_wf)
thus ?thesis
proof (induct args arbitrary: data D rule: wf_induct_rule)
fix x data D
assume IH: "⋀y data' D'. (y, x) ∈ ?R ⟹ gb_schema_dummy_dom (data', D', y)"
obtain bs ps where x: "x = (bs, ps)" by (meson case_prodE case_prodI2)
show "gb_schema_dummy_dom (data, D, x)" unfolding x
proof (rule gb_schema_dummy.domintros)
fix rc0 n0 data0 hs n1 data1
assume "ps ≠ []"
and hs_data': "(hs, n1, data1) = add_indices (compl gs bs (ps -- sel gs bs ps (n0, data0))
(sel gs bs ps (n0, data0)) (n0, data0)) (n0, data0)"
and data: "data = (rc0, n0, data0)"
define sps where "sps = sel gs bs ps (n0, data0)"
define data' where "data' = (n1, data1)"
define D' where "D' = D ∪
(set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) -⇩p
set (ap gs bs (ps -- sps) hs data'))"
define rc where "rc = rc0 - count_const_lt_components (fst (compl gs bs (ps -- sel gs bs ps (n0, data0))
(sel gs bs ps (n0, data0)) (n0, data0)))"
from hs_data' have hs: "hs = fst (add_indices (compl gs bs (ps -- sps) sps (snd data)) (snd data))"
unfolding sps_def data snd_conv by (metis fstI)
show "gb_schema_dummy_dom ((rc, data'), D', ab gs bs hs data', ap gs bs (ps -- sps) hs data')"
proof (rule IH, simp add: x gb_schema_aux_term_def gb_schema_aux_term1_def gb_schema_aux_term2_def, intro conjI)
show "fst ` set (ab gs bs hs data') ⊐p fst ` set bs ∨
ab gs bs hs data' = bs ∧ card (set (ap gs bs (ps -- sps) hs data')) < card (set ps)"
proof (cases "hs = []")
case True
have "ab gs bs hs data' = bs ∧ card (set (ap gs bs (ps -- sps) hs data')) < card (set ps)"
proof (simp only: True, rule)
from ab show "ab gs bs [] data' = bs" by (rule ab_specD2)
next
from sel ‹ps ≠ []› have "sps ≠ []" and "set sps ⊆ set ps"
unfolding sps_def by (rule sel_specD1, rule sel_specD2)
moreover from sel_specD1[OF sel ‹ps ≠ []›] have "set sps ≠ {}" by (simp add: sps_def)
ultimately have "set ps ∩ set sps ≠ {}" by (simp add: inf.absorb_iff2)
hence "set (ps -- sps) ⊂ set ps" unfolding set_diff_list by fastforce
hence "card (set (ps -- sps)) < card (set ps)" by (simp add: psubset_card_mono)
moreover have "card (set (ap gs bs (ps -- sps) [] data')) ≤ card (set (ps -- sps))"
by (rule card_mono, fact finite_set, rule ap_spec_Nil_subset, fact ap)
ultimately show "card (set (ap gs bs (ps -- sps) [] data')) < card (set ps)" by simp
qed
thus ?thesis ..
next
case False
with assms ‹ps ≠ []› sps_def hs have "fst ` set (ab gs bs hs data') ⊐p fst ` set bs"
unfolding data snd_conv by (rule struct_spec_red_supset)
thus ?thesis ..
qed
next
from dg assms ‹ps ≠ []› sps_def hs
show "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))"
unfolding data snd_conv by (rule dgrad_p_set_le_args_to_set_struct)
next
from assms ‹ps ≠ []› sps_def hs
show "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) ⊆
component_of_term ` Keys (args_to_set (gs, bs, ps))"
unfolding data snd_conv by (rule components_subset_struct)
qed
qed
qed
qed
lemmas gb_schema_dummy_simp = gb_schema_dummy.psimps[OF gb_schema_dummy_domI2]
lemma gb_schema_dummy_Nil [simp]: "gb_schema_dummy data D bs [] = (gs @ bs, D)"
by (simp add: gb_schema_dummy.psimps[OF gb_schema_dummy_domI1])
lemma gb_schema_dummy_not_Nil:
assumes "struct_spec sel ap ab compl" and "ps ≠ []"
shows "gb_schema_dummy data D bs ps =
(let sps = sel gs bs ps (snd data); ps0 = ps -- sps; aux = compl gs bs ps0 sps (snd data);
remcomps = fst (data) - count_const_lt_components (fst aux) in
(if remcomps = 0 then
(full_gb (gs @ bs), D)
else
let (hs, data') = add_indices aux (snd data) in
gb_schema_dummy (remcomps, data')
(D ∪ ((set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)) -⇩p set (ap gs bs ps0 hs data')))
(ab gs bs hs data') (ap gs bs ps0 hs data')
)
)"
by (simp add: gb_schema_dummy_simp[OF assms(1)] assms(2))
lemma gb_schema_dummy_induct [consumes 1, case_names base rec1 rec2]:
assumes "struct_spec sel ap ab compl"
assumes base: "⋀bs data D. P data D bs [] (gs @ bs, D)"
and rec1: "⋀bs ps sps data D. ps ≠ [] ⟹ sps = sel gs bs ps (snd data) ⟹
fst (data) ≤ count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data))) ⟹
P data D bs ps (full_gb (gs @ bs), D)"
and rec2: "⋀bs ps sps aux hs rc data data' D D'. ps ≠ [] ⟹ sps = sel gs bs ps (snd data) ⟹
aux = compl gs bs (ps -- sps) sps (snd data) ⟹ (hs, data') = add_indices aux (snd data) ⟹
rc = fst data - count_const_lt_components (fst aux) ⟹ 0 < rc ⟹
D' = (D ∪ ((set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)) -⇩p set (ap gs bs (ps -- sps) hs data'))) ⟹
P (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')
(gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')) ⟹
P data D bs ps (gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))"
shows "P data D bs ps (gb_schema_dummy data D bs ps)"
proof -
from assms(1) have "gb_schema_dummy_dom (data, D, bs, ps)" by (rule gb_schema_dummy_domI2)
thus ?thesis
proof (induct data D bs ps rule: gb_schema_dummy.pinduct)
case (1 data D bs ps)
show ?case
proof (cases "ps = []")
case True
show ?thesis by (simp add: True, rule base)
next
case False
show ?thesis
proof (simp only: gb_schema_dummy_not_Nil[OF assms(1) False] Let_def split: if_split, intro conjI impI)
define sps where "sps = sel gs bs ps (snd data)"
assume "fst data - count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data))) = 0"
hence "fst data ≤ count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data)))"
by simp
with False sps_def show "P data D bs ps (full_gb (gs @ bs), D)" by (rule rec1)
next
define sps where "sps = sel gs bs ps (snd data)"
define aux where "aux = compl gs bs (ps -- sps) sps (snd data)"
define hs where "hs = fst (add_indices aux (snd data))"
define data' where "data' = snd (add_indices aux (snd data))"
define rc where "rc = fst data - count_const_lt_components (fst aux)"
define D' where "D' = (D ∪ ((set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps)) -⇩p set (ap gs bs (ps -- sps) hs data')))"
have eq: "add_indices aux (snd data) = (hs, data')" by (simp add: hs_def data'_def)
assume "rc ≠ 0"
hence "0 < rc" by simp
show "P data D bs ps
(case add_indices aux (snd data) of
(hs, data') ⇒
gb_schema_dummy (rc, data')
(D ∪ (set hs × (set gs ∪ set bs ∪ set hs) ∪ set (ps -- sps) -⇩p set (ap gs bs (ps -- sps) hs data')))
(ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))"
unfolding eq prod.case D'_def[symmetric] using False sps_def aux_def eq[symmetric] rc_def ‹0 < rc› D'_def
proof (rule rec2)
show "P (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')
(gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))"
unfolding D'_def using False sps_def refl aux_def rc_def ‹rc ≠ 0› eq[symmetric] refl
by (rule 1)
qed
qed
qed
qed
qed
lemma fst_gb_schema_dummy_dgrad_p_set_le:
assumes "dickson_grading d" and "struct_spec sel ap ab compl"
shows "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy data D bs ps))) (args_to_set (gs, bs, ps))"
using assms(2)
proof (induct rule: gb_schema_dummy_induct)
case (base bs data D)
show ?case by (simp add: args_to_set_def, rule dgrad_p_set_le_subset, fact subset_refl)
next
case (rec1 bs ps sps data D)
show ?case
proof (cases "fst ` set gs ∪ fst ` set bs ⊆ {0}")
case True
hence "Keys (fst ` set (gs @ bs)) = {}" by (auto simp add: image_Un Keys_def)
hence "component_of_term ` Keys (fst ` set (full_gb (gs @ bs))) = {}"
by (simp add: components_full_gb)
hence "Keys (fst ` set (full_gb (gs @ bs))) = {}" by simp
thus ?thesis by (simp add: dgrad_p_set_le_def dgrad_set_le_def)
next
case False
from pps_full_gb have "dgrad_set_le d (pp_of_term ` Keys (fst ` set (full_gb (gs @ bs)))) {0}"
by (rule dgrad_set_le_subset)
also have "dgrad_set_le d ... (pp_of_term ` Keys (args_to_set (gs, bs, ps)))"
proof (rule dgrad_set_leI, simp)
from False have "Keys (args_to_set (gs, bs, ps)) ≠ {}"
by (simp add: args_to_set_alt Keys_Un, metis Keys_not_empty singletonI subsetI)
then obtain v where "v ∈ Keys (args_to_set (gs, bs, ps))" by blast
moreover have "d 0 ≤ d (pp_of_term v)" by (simp add: assms(1) dickson_grading_adds_imp_le)
ultimately show "∃t∈Keys (args_to_set (gs, bs, ps)). d 0 ≤ d (pp_of_term t)" ..
qed
finally show ?thesis by (simp add: dgrad_p_set_le_def)
qed
next
case (rec2 bs ps sps aux hs rc data data' D D')
from rec2(4) have "hs = fst (add_indices (compl gs bs (ps -- sps) sps (snd data)) (snd data))"
unfolding rec2(3) by (metis fstI)
with assms rec2(1, 2)
have "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))"
by (rule dgrad_p_set_le_args_to_set_struct)
with rec2(8) show ?case by (rule dgrad_p_set_le_trans)
qed
lemma fst_gb_schema_dummy_components:
assumes "struct_spec sel ap ab compl" and "set ps ⊆ (set bs) × (set gs ∪ set bs)"
shows "component_of_term ` Keys (fst ` set (fst (gb_schema_dummy data D bs ps))) =
component_of_term ` Keys (args_to_set (gs, bs, ps))"
using assms
proof (induct rule: gb_schema_dummy_induct)
case (base bs data D)
show ?case by (simp add: args_to_set_def)
next
case (rec1 bs ps sps data D)
have "component_of_term ` Keys (fst ` set (full_gb (gs @ bs))) =
component_of_term ` Keys (fst ` set (gs @ bs))" by (fact components_full_gb)
also have "... = component_of_term ` Keys (args_to_set (gs, bs, ps))"
by (simp add: args_to_set_subset_Times[OF rec1.prems] image_Un)
finally show ?case by simp
next
case (rec2 bs ps sps aux hs rc data data' D D')
from assms(1) have ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+
from this rec2.prems
have sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))"
by (rule subset_Times_ap)
from rec2(4) have hs: "hs = fst (add_indices (compl gs bs (ps -- sps) sps (snd data)) (snd data))"
unfolding rec2(3) by (metis fstI)
have "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) =
component_of_term ` Keys (args_to_set (gs, bs, ps))" (is "?l = ?r")
proof
from assms(1) rec2(1, 2) hs show "?l ⊆ ?r" by (rule components_subset_struct)
next
show "?r ⊆ ?l"
by (simp add: args_to_set_subset_Times[OF rec2.prems] args_to_set_alt2[OF ap ab rec2.prems] image_Un,
rule image_mono, rule Keys_mono, blast)
qed
with rec2.hyps(8)[OF sub] show ?case by (rule trans)
qed
lemma fst_gb_schema_dummy_pmdl:
assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)"
and "set ps ⊆ set bs × (set gs ∪ set bs)" and "unique_idx (gs @ bs) (snd data)"
and "rem_comps_spec (gs @ bs) data"
shows "pmdl (fst ` set (fst (gb_schema_dummy data D bs ps))) = pmdl (fst ` set (gs @ bs))"
proof -
from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" and compl: "compl_struct compl"
by (rule struct_specD)+
from assms(1, 4, 5, 6) show ?thesis
proof (induct bs ps rule: gb_schema_dummy_induct)
case (base bs data D)
show ?case by simp
next
case (rec1 bs ps sps data D)
define aux where "aux = compl gs bs (ps -- sps) sps (snd data)"
define data' where "data' = snd (add_indices aux (snd data))"
define hs where "hs = fst (add_indices aux (snd data))"
have hs_data': "(hs, data') = add_indices aux (snd data)" by (simp add: hs_def data'_def)
have eq: "set (gs @ ab gs bs hs data') = set (gs @ bs @ hs)" by (simp add: ab_specD1[OF ab])
from sel rec1(1) have "sps ≠ []" and "set sps ⊆ set ps" unfolding rec1(2)
by (rule sel_specD1, rule sel_specD2)
from full_gb_is_full_pmdl have "pmdl (fst ` set (full_gb (gs @ bs))) = pmdl (fst ` set (gs @ ab gs bs hs data'))"
proof (rule is_full_pmdl_eq)
show "is_full_pmdl (fst ` set (gs @ ab gs bs hs data'))"
proof (rule is_full_pmdlI_lt_finite)
from finite_set show "finite (fst ` set (gs @ ab gs bs hs data'))" by (rule finite_imageI)
next
fix k
assume "k ∈ component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data'))"
hence "Some k ∈ Some ` component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data'))" by simp
also have "... = const_lt_component ` (fst ` set (gs @ ab gs bs hs data') - {0}) - {None}" (is "?A = ?B")
proof (rule card_seteq[symmetric])
show "finite ?A" by (intro finite_imageI finite_Keys, fact finite_set)
next
have "rem_comps_spec (gs @ ab gs bs hs data') (fst data - count_const_lt_components (fst aux), data')"
using assms(1) rec1.prems(3) rec1.hyps(1) rec1.prems(1) rec1.hyps(2) aux_def hs_data'
by (rule rem_comps_spec_struct)
also have "... = (0, data')" by (simp add: aux_def rec1.hyps(3))
finally have "card (const_lt_component ` (fst ` set (gs @ ab gs bs hs data') - {0}) - {None}) =
card (component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data')))"
by (simp add: rem_comps_spec_def)
also have "... = card (Some ` component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data')))"
by (rule card_image[symmetric], simp)
finally show "card ?A ≤ card ?B" by simp
qed (fact const_lt_component_subset)
finally have "Some k ∈ const_lt_component ` (fst ` set (gs @ ab gs bs hs data') - {0})"
by simp
then obtain b where "b ∈ fst ` set (gs @ ab gs bs hs data')" and "b ≠ 0"
and *: "const_lt_component b = Some k" by fastforce
show "∃b∈fst ` set (gs @ ab gs bs hs data'). b ≠ 0 ∧ component_of_term (lt b) = k ∧ lp b = 0"
proof (intro bexI conjI)
from * show "component_of_term (lt b) = k" by (rule const_lt_component_SomeD2)
next
from * show "lp b = 0" by (rule const_lt_component_SomeD1)
qed fact+
qed
next
from compl ‹sps ≠ []› ‹set sps ⊆ set ps›
have "component_of_term ` Keys (fst ` set hs) ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))"
unfolding hs_def aux_def fst_set_add_indices by (rule compl_structD2)
hence sub: "component_of_term ` Keys (fst ` set hs) ⊆ component_of_term ` Keys (fst ` set (gs @ bs))"
by (simp add: args_to_set_subset_Times[OF rec1.prems(1)] image_Un)
have "component_of_term ` Keys (fst ` set (full_gb (gs @ bs))) =
component_of_term ` Keys (fst ` set (gs @ bs))" by (fact components_full_gb)
also have "... = component_of_term ` Keys (fst ` set ((gs @ bs) @ hs))"
by (simp only: set_append[of _ hs] image_Un Keys_Un Un_absorb2 sub)
finally show "component_of_term ` Keys (fst ` set (full_gb (gs @ bs))) =
component_of_term ` Keys (fst ` set (gs @ ab gs bs hs data'))"
by (simp only: eq append_assoc)
qed
also have "... = pmdl (fst ` set (gs @ bs))"
using assms(1, 2, 3) rec1.hyps(1) rec1.prems(1, 2) rec1.hyps(2) aux_def hs_data'
by (rule pmdl_struct)
finally show ?case by simp
next
case (rec2 bs ps sps aux hs rc data data' D D')
from rec2(4) have hs: "hs = fst (add_indices aux (snd data))" by (metis fstI)
have "pmdl (fst ` set (fst (gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')))) =
pmdl (fst ` set (gs @ ab gs bs hs data'))"
proof (rule rec2.hyps(8))
from ap ab rec2.prems(1)
show "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))"
by (rule subset_Times_ap)
next
from ab rec2.prems(2) rec2(4) show "unique_idx (gs @ ab gs bs hs data') (snd (rc, data'))"
unfolding snd_conv by (rule unique_idx_ab)
next
show "rem_comps_spec (gs @ ab gs bs hs data') (rc, data')" unfolding rec2.hyps(5)
using assms(1) rec2.prems(3) rec2.hyps(1) rec2.prems(1) rec2.hyps(2, 3, 4)
by (rule rem_comps_spec_struct)
qed
also have "... = pmdl (fst ` set (gs @ bs))"
using assms(1, 2, 3) rec2.hyps(1) rec2.prems(1, 2) rec2.hyps(2, 3, 4) by (rule pmdl_struct)
finally show ?case .
qed
qed
lemma snd_gb_schema_dummy_subset:
assumes "struct_spec sel ap ab compl" and "set ps ⊆ set bs × (set gs ∪ set bs)"
and "D ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)" and "res = gb_schema_dummy data D bs ps"
shows "snd res ⊆ set (fst res) × set (fst res) ∨ (∃xs. fst (res) = full_gb xs)"
using assms
proof (induct data D bs ps rule: gb_schema_dummy_induct)
case (base bs data D)
from base(2) show ?case by (simp add: base(3))
next
case (rec1 bs ps sps data D)
have "∃xs. fst res = full_gb xs" by (auto simp: rec1(6))
thus ?case ..
next
case (rec2 bs ps sps aux hs rc data data' D D')
from assms(1) have ab: "ab_spec ab" and ap: "ap_spec ap" by (rule struct_specD)+
from _ _ rec2.prems(3) show ?case
proof (rule rec2.hyps(8))
from ap ab rec2.prems(1)
show "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))"
by (rule subset_Times_ap)
next
from ab rec2.hyps(7) rec2.prems(1) rec2.prems(2)
show "D' ⊆ (set gs ∪ set (ab gs bs hs data')) × (set gs ∪ set (ab gs bs hs data'))"
by (rule discarded_subset)
qed
qed
lemma gb_schema_dummy_connectible1:
assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "dickson_grading d"
and "fst ` set gs ⊆ dgrad_p_set d m" and "is_Groebner_basis (fst ` set gs)"
and "fst ` set bs ⊆ dgrad_p_set d m"
and "set ps ⊆ set bs × (set gs ∪ set bs)"
and "unique_idx (gs @ bs) (snd data)"
and "⋀p q. processed (p, q) (gs @ bs) ps ⟹ (p, q) ∉⇩p D ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs)) (fst p) (fst q)"
and "¬(∃xs. fst (gb_schema_dummy data D bs ps) = full_gb xs)"
assumes "f ∈ set (fst (gb_schema_dummy data D bs ps))"
and "g ∈ set (fst (gb_schema_dummy data D bs ps))"
and "(f, g) ∉⇩p snd (gb_schema_dummy data D bs ps)"
and "fst f ≠ 0" and "fst g ≠ 0"
shows "crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst f) (fst g)"
using assms(1, 6, 7, 8, 9, 10, 11, 12, 13)
proof (induct data D bs ps rule: gb_schema_dummy_induct)
case (base bs data D)
show ?case
proof (cases "f ∈ set gs")
case True
show ?thesis
proof (cases "g ∈ set gs")
case True
note assms(3, 4, 5)
moreover from ‹f ∈ set gs› have "fst f ∈ fst ` set gs" by simp
moreover from ‹g ∈ set gs› have "fst g ∈ fst ` set gs" by simp
ultimately have "crit_pair_cbelow_on d m (fst ` set gs) (fst f) (fst g)"
using assms(14, 15) by (rule GB_imp_crit_pair_cbelow_dgrad_p_set)
moreover have "fst ` set gs ⊆ fst ` set (fst (gs @ bs, D))" by auto
ultimately show ?thesis by (rule crit_pair_cbelow_mono)
next
case False
from this base(6, 7) have "processed (g, f) (gs @ bs) []" by (simp add: processed_Nil)
moreover from base.prems(8) have "(g, f) ∉⇩p D" by (simp add: in_pair_iff)
ultimately have "crit_pair_cbelow_on d m (fst ` set (gs @ bs)) (fst g) (fst f)"
using ‹fst g ≠ 0› ‹fst f ≠ 0› unfolding set_append by (rule base(4))
thus ?thesis unfolding fst_conv by (rule crit_pair_cbelow_sym)
qed
next
case False
from this base(6, 7) have "processed (f, g) (gs @ bs) []" by (simp add: processed_Nil)
moreover from base.prems(8) have "(f, g) ∉⇩p D" by simp
ultimately show ?thesis unfolding fst_conv set_append using ‹fst f ≠ 0› ‹fst g ≠ 0› by (rule base(4))
qed
next
case (rec1 bs ps sps data D)
from rec1.prems(5) show ?case by auto
next
case (rec2 bs ps sps aux hs rc data data' D D')
from rec2.hyps(4) have hs: "hs = fst (add_indices aux (snd data))" by (metis fstI)
from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab"
and compl: "compl_struct compl"
by (rule struct_specD1, rule struct_specD2, rule struct_specD3, rule struct_specD4)
from sel rec2.hyps(1) have "sps ≠ []" and "set sps ⊆ set ps"
unfolding rec2.hyps(2) by (rule sel_specD1, rule sel_specD2)
from ap ab rec2.prems(2) have ap_sub: "set (ap gs bs (ps -- sps) hs data') ⊆
set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))"
by (rule subset_Times_ap)
have ns_sub: "fst ` set hs ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
from compl assms(3) ‹sps ≠ []› ‹set sps ⊆ set ps›
show "dgrad_p_set_le d (fst ` set hs) (args_to_set (gs, bs, ps))"
unfolding hs rec2.hyps(3) fst_set_add_indices by (rule compl_structD1)
next
from assms(4) rec2.prems(1) show "args_to_set (gs, bs, ps) ⊆ dgrad_p_set d m"
by (simp add: args_to_set_subset_Times[OF rec2.prems(2)])
qed
with rec2.prems(1) have ab_sub: "fst ` set (ab gs bs hs data') ⊆ dgrad_p_set d m"
by (auto simp add: ab_specD1[OF ab])
have cpq: "(p, q) ∈⇩p set sps ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` (set gs ∪ set (ab gs bs hs data'))) (fst p) (fst q)" for p q
proof -
assume "(p, q) ∈⇩p set sps" and "fst p ≠ 0" and "fst q ≠ 0"
from this(1) have "(p, q) ∈ set sps ∨ (q, p) ∈ set sps" by (simp only: in_pair_iff)
hence "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps (snd data))))
(fst p) (fst q)"
proof
assume "(p, q) ∈ set sps"
from assms(2, 3, 4, 5) rec2.prems(1, 2) ‹sps ≠ []› ‹set sps ⊆ set ps› rec2.prems(3) this
‹fst p ≠ 0› ‹fst q ≠ 0› show ?thesis by (rule compl_connD)
next
assume "(q, p) ∈ set sps"
from assms(2, 3, 4, 5) rec2.prems(1, 2) ‹sps ≠ []› ‹set sps ⊆ set ps› rec2.prems(3) this
‹fst q ≠ 0› ‹fst p ≠ 0›
have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (compl gs bs (ps -- sps) sps (snd data))))
(fst q) (fst p)" by (rule compl_connD)
thus ?thesis by (rule crit_pair_cbelow_sym)
qed
thus "crit_pair_cbelow_on d m (fst ` (set gs ∪ set (ab gs bs hs data'))) (fst p) (fst q)"
by (simp add: ab_specD1[OF ab] hs rec2.hyps(3) fst_set_add_indices image_Un Un_assoc)
qed
from ab_sub ap_sub _ _ rec2.prems(5, 6, 7, 8) show ?case
proof (rule rec2.hyps(8))
from ab rec2.prems(3) rec2(4) show "unique_idx (gs @ ab gs bs hs data') (snd (rc, data'))"
unfolding snd_conv by (rule unique_idx_ab)
next
fix p q :: "('t, 'b, 'c) pdata"
define ps' where "ps' = ap gs bs (ps -- sps) hs data'"
assume "fst p ≠ 0" and "fst q ≠ 0" and "(p, q) ∉⇩p D'"
assume "processed (p, q) (gs @ ab gs bs hs data') ps'"
hence p_in: "p ∈ set gs ∪ set bs ∪ set hs" and q_in: "q ∈ set gs ∪ set bs ∪ set hs"
and "(p, q) ∉⇩p set ps'" by (simp_all add: processed_alt ab_specD1[OF ab])
from this(3) ‹(p, q) ∉⇩p D'› have "(p, q) ∉⇩p D" and "(p, q) ∉⇩p set (ps -- sps)"
and "(p, q) ∉⇩p set hs × (set gs ∪ set bs ∪ set hs)"
by (auto simp: in_pair_iff rec2.hyps(7) ps'_def)
from this(3) p_in q_in have "p ∈ set gs ∪ set bs" and "q ∈ set gs ∪ set bs"
by (meson SigmaI UnE in_pair_iff)+
show "crit_pair_cbelow_on d m (fst ` (set gs ∪ set (ab gs bs hs data'))) (fst p) (fst q)"
proof (cases "component_of_term (lt (fst p)) = component_of_term (lt (fst q))")
case True
show ?thesis
proof (cases "(p, q) ∈⇩p set sps")
case True
from this ‹fst p ≠ 0› ‹fst q ≠ 0› show ?thesis by (rule cpq)
next
case False
with ‹(p, q) ∉⇩p set (ps -- sps)› have "(p, q) ∉⇩p set ps"
by (auto simp: in_pair_iff set_diff_list)
with ‹p ∈ set gs ∪ set bs› ‹q ∈ set gs ∪ set bs› have "processed (p, q) (gs @ bs) ps"
by (simp add: processed_alt)
from this ‹(p, q) ∉⇩p D› ‹fst p ≠ 0› ‹fst q ≠ 0›
have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs)) (fst p) (fst q)"
by (rule rec2.prems(4))
moreover have "fst ` (set gs ∪ set bs) ⊆ fst ` (set gs ∪ set (ab gs bs hs data'))"
by (auto simp: ab_specD1[OF ab])
ultimately show ?thesis by (rule crit_pair_cbelow_mono)
qed
next
case False
thus ?thesis by (rule crit_pair_cbelow_distinct_component)
qed
qed
qed
lemma gb_schema_dummy_connectible2:
assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "dickson_grading d"
and "fst ` set gs ⊆ dgrad_p_set d m" and "is_Groebner_basis (fst ` set gs)"
and "fst ` set bs ⊆ dgrad_p_set d m"
and "set ps ⊆ set bs × (set gs ∪ set bs)" and "D ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)"
and "set ps ∩⇩p D = {}" and "unique_idx (gs @ bs) (snd data)"
and "⋀B a b. set gs ∪ set bs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹ (a, b) ∈⇩p D ⟹
fst a ≠ 0 ⟹ fst b ≠ 0 ⟹
(⋀x y. x ∈ set gs ∪ set bs ⟹ y ∈ set gs ∪ set bs ⟹ ¬ (x, y) ∈⇩p D ⟹
fst x ≠ 0 ⟹ fst y ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)) ⟹
crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
and "⋀x y. x ∈ set (fst (gb_schema_dummy data D bs ps)) ⟹ y ∈ set (fst (gb_schema_dummy data D bs ps)) ⟹
(x, y) ∉⇩p snd (gb_schema_dummy data D bs ps) ⟹ fst x ≠ 0 ⟹ fst y ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst x) (fst y)"
and "¬(∃xs. fst (gb_schema_dummy data D bs ps) = full_gb xs)"
assumes "(f, g) ∈⇩p snd (gb_schema_dummy data D bs ps)"
and "fst f ≠ 0" and "fst g ≠ 0"
shows "crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst f) (fst g)"
using assms(1, 6, 7, 8, 9, 10, 11, 12, 13, 14, 15, 16)
proof (induct data D bs ps rule: gb_schema_dummy_induct)
case (base bs data D)
have "set gs ∪ set bs ⊆ set (fst (gs @ bs, D))" by simp
moreover from assms(4) base.prems(1) have "fst ` set (fst (gs @ bs, D)) ⊆ dgrad_p_set d m" by auto
moreover from base.prems(9) have "(f, g) ∈⇩p D" by simp
moreover note assms(15, 16)
ultimately show ?case
proof (rule base.prems(6))
fix x y
assume "x ∈ set gs ∪ set bs" and "y ∈ set gs ∪ set bs" and "(x, y) ∉⇩p D"
hence "x ∈ set (fst (gs @ bs, D))" and "y ∈ set (fst (gs @ bs, D))" and "(x, y) ∉⇩p snd (gs @ bs, D)"
by simp_all
moreover assume "fst x ≠ 0" and "fst y ≠ 0"
ultimately show "crit_pair_cbelow_on d m (fst ` set (fst (gs @ bs, D))) (fst x) (fst y)"
by (rule base.prems(7))
qed
next
case (rec1 bs ps sps data D)
from rec1.prems(8) show ?case by auto
next
case (rec2 bs ps sps aux hs rc data data' D D')
from rec2.hyps(4) have hs: "hs = fst (add_indices aux (snd data))" by (metis fstI)
from assms(1) have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab"
and compl: "compl_struct compl" by (rule struct_specD)+
let ?X = "set (ps -- sps) ∪ set hs × (set gs ∪ set bs ∪ set hs)"
from sel rec2.hyps(1) have "sps ≠ []" and "set sps ⊆ set ps"
unfolding rec2.hyps(2) by (rule sel_specD1, rule sel_specD2)
have "fst ` set hs ∩ fst ` (set gs ∪ set bs) = {}"
unfolding hs fst_set_add_indices rec2.hyps(3) using compl ‹sps ≠ []› ‹set sps ⊆ set ps›
by (rule compl_struct_disjoint)
hence disj1: "(set gs ∪ set bs) ∩ set hs = {}" by fastforce
have disj2: "set (ap gs bs (ps -- sps) hs data') ∩⇩p D' = {}"
proof (rule, rule)
fix x y
assume "(x, y) ∈ set (ap gs bs (ps -- sps) hs data') ∩⇩p D'"
hence "(x, y) ∈⇩p set (ap gs bs (ps -- sps) hs data') ∩⇩p D'" by (simp add: in_pair_alt)
hence 1: "(x, y) ∈⇩p set (ap gs bs (ps -- sps) hs data')" and "(x, y) ∈⇩p D'" by simp_all
hence "(x, y) ∈⇩p D" by (simp add: rec2.hyps(7))
from this rec2.prems(3) have "x ∈ set gs ∪ set bs" and "y ∈ set gs ∪ set bs"
by (auto simp: in_pair_iff)
from 1 ap_specD1[OF ap] have "(x, y) ∈⇩p ?X" by (rule in_pair_trans)
thus "(x, y) ∈ {}" unfolding in_pair_Un
proof
assume "(x, y) ∈⇩p set (ps -- sps)"
also have "... ⊆ set ps" by (auto simp: set_diff_list)
finally have "(x, y) ∈⇩p set ps ∩⇩p D" using ‹(x, y) ∈⇩p D› by simp
also have "... = {}" by (fact rec2.prems(4))
finally show ?thesis by (simp add: in_pair_iff)
next
assume "(x, y) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)"
hence "x ∈ set hs ∨ y ∈ set hs" by (auto simp: in_pair_iff)
thus ?thesis
proof
assume "x ∈ set hs"
with ‹x ∈ set gs ∪ set bs› have "x ∈ (set gs ∪ set bs) ∩ set hs" ..
thus ?thesis by (simp add: disj1)
next
assume "y ∈ set hs"
with ‹y ∈ set gs ∪ set bs› have "y ∈ (set gs ∪ set bs) ∩ set hs" ..
thus ?thesis by (simp add: disj1)
qed
qed
qed simp
have hs_sub: "fst ` set hs ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
from compl assms(3) ‹sps ≠ []› ‹set sps ⊆ set ps›
show "dgrad_p_set_le d (fst ` set hs) (args_to_set (gs, bs, ps))"
unfolding hs rec2.hyps(3) fst_set_add_indices by (rule compl_structD1)
next
from assms(4) rec2.prems(1) show "args_to_set (gs, bs, ps) ⊆ dgrad_p_set d m"
by (simp add: args_to_set_subset_Times[OF rec2.prems(2)])
qed
with rec2.prems(1) have ab_sub: "fst ` set (ab gs bs hs data') ⊆ dgrad_p_set d m"
by (auto simp add: ab_specD1[OF ab])
moreover from ap ab rec2.prems(2)
have ap_sub: "set (ap gs bs (ps -- sps) hs data') ⊆ set (ab gs bs hs data') × (set gs ∪ set (ab gs bs hs data'))"
by (rule subset_Times_ap)
moreover from ab rec2.hyps(7) rec2.prems(2) rec2.prems(3)
have "D' ⊆ (set gs ∪ set (ab gs bs hs data')) × (set gs ∪ set (ab gs bs hs data'))"
by (rule discarded_subset)
moreover note disj2
moreover from ab rec2.prems(5) rec2.hyps(4) have uid: "unique_idx (gs @ ab gs bs hs data') (snd (rc, data'))"
unfolding snd_conv by (rule unique_idx_ab)
ultimately show ?case using _ _ rec2.prems(8, 9, 10, 11)
proof (rule rec2.hyps(8), simp only: ab_specD1[OF ab] Un_assoc[symmetric])
define ps' where "ps' = ap gs bs (ps -- sps) hs data'"
fix B a b
assume B_sup: "set gs ∪ set bs ∪ set hs ⊆ B"
hence "set gs ∪ set bs ⊆ B" and "set hs ⊆ B" by simp_all
assume "(a, b) ∈⇩p D'"
hence ab_cases: "(a, b) ∈⇩p D ∨ (a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) -⇩p set ps' ∨
(a, b) ∈⇩p set (ps -- sps) -⇩p set ps'" by (auto simp: rec2.hyps(7) ps'_def)
assume B_sub: "fst ` B ⊆ dgrad_p_set d m" and "fst a ≠ 0" and "fst b ≠ 0"
assume *: "⋀x y. x ∈ set gs ∪ set bs ∪ set hs ⟹ y ∈ set gs ∪ set bs ∪ set hs ⟹
(x, y) ∉⇩p D' ⟹ fst x ≠ 0 ⟹ fst y ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)"
from rec2.prems(2) have ps_sps_sub: "set (ps -- sps) ⊆ set bs × (set gs ∪ set bs)"
by (auto simp: set_diff_list)
from uid have uid': "unique_idx (gs @ bs @ hs) data'" by (simp add: unique_idx_def ab_specD1[OF ab])
have a: "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)"
if "fst x ≠ 0" and "fst y ≠ 0" and xy_in: "(x, y) ∈⇩p set (ps -- sps) -⇩p set ps'" for x y
proof (cases "x = y")
case True
from xy_in rec2.prems(2) have "y ∈ set gs ∪ set bs"
unfolding in_pair_minus_pairs unfolding True in_pair_iff set_diff_list by auto
hence "fst y ∈ fst ` set gs ∪ fst ` set bs" by fastforce
from this assms(4) rec2.prems(1) have "fst y ∈ dgrad_p_set d m" by blast
with assms(3) show ?thesis unfolding True by (rule crit_pair_cbelow_same)
next
case False
from ap assms(3) B_sup B_sub ps_sps_sub disj1 uid' assms(5) False ‹fst x ≠ 0› ‹fst y ≠ 0› xy_in
show ?thesis unfolding ps'_def
proof (rule ap_specD3)
fix a1 b1 :: "('t, 'b, 'c) pdata"
assume "fst a1 ≠ 0" and "fst b1 ≠ 0"
assume "a1 ∈ set hs" and b1_in: "b1 ∈ set gs ∪ set bs ∪ set hs"
hence a1_in: "a1 ∈ set gs ∪ set bs ∪ set hs" by fastforce
assume "(a1, b1) ∈⇩p set (ap gs bs (ps -- sps) hs data')"
hence "(a1, b1) ∈⇩p set ps'" by (simp only: ps'_def)
with disj2 have "(a1, b1) ∉⇩p D'" unfolding ps'_def
by (metis empty_iff in_pair_Int_pairs in_pair_alt)
with a1_in b1_in show "crit_pair_cbelow_on d m (fst ` B) (fst a1) (fst b1)"
using ‹fst a1 ≠ 0› ‹fst b1 ≠ 0› by (rule *)
qed
qed
have b: "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)"
if "(x, y) ∈⇩p D" and "fst x ≠ 0" and "fst y ≠ 0" for x y
using ‹set gs ∪ set bs ⊆ B› B_sub that
proof (rule rec2.prems(6))
fix a1 b1 :: "('t, 'b, 'c) pdata"
assume "a1 ∈ set gs ∪ set bs" and "b1 ∈ set gs ∪ set bs"
hence a1_in: "a1 ∈ set gs ∪ set bs ∪ set hs" and b1_in: "b1 ∈ set gs ∪ set bs ∪ set hs"
by fastforce+
assume "(a1, b1) ∉⇩p D" and "fst a1 ≠ 0" and "fst b1 ≠ 0"
show "crit_pair_cbelow_on d m (fst ` B) (fst a1) (fst b1)"
proof (cases "(a1, b1) ∈⇩p ?X -⇩p set ps'")
case True
moreover from ‹a1 ∈ set gs ∪ set bs› ‹b1 ∈ set gs ∪ set bs› disj1
have "(a1, b1) ∉⇩p set hs × (set gs ∪ set bs ∪ set hs)"
by (auto simp: in_pair_def)
ultimately have "(a1, b1) ∈⇩p set (ps -- sps) -⇩p set ps'" by auto
with ‹fst a1 ≠ 0› ‹fst b1 ≠ 0› show ?thesis by (rule a)
next
case False
with ‹(a1, b1) ∉⇩p D› have "(a1, b1) ∉⇩p D'" by (auto simp: rec2.hyps(7) ps'_def)
with a1_in b1_in show ?thesis using ‹fst a1 ≠ 0› ‹fst b1 ≠ 0› by (rule *)
qed
qed
have c: "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)"
if x_in: "x ∈ set gs ∪ set bs ∪ set hs" and y_in: "y ∈ set gs ∪ set bs ∪ set hs"
and xy: "(x, y) ∉⇩p (?X -⇩p set ps')" and "fst x ≠ 0" and "fst y ≠ 0" for x y
proof (cases "(x, y) ∈⇩p D")
case True
thus ?thesis using ‹fst x ≠ 0› ‹fst y ≠ 0› by (rule b)
next
case False
with xy have "(x, y) ∉⇩p D'" unfolding rec2.hyps(7) ps'_def by auto
with x_in y_in show ?thesis using ‹fst x ≠ 0› ‹fst y ≠ 0› by (rule *)
qed
from ab_cases show "crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
proof (elim disjE)
assume "(a, b) ∈⇩p D"
thus ?thesis using ‹fst a ≠ 0› ‹fst b ≠ 0› by (rule b)
next
assume ab_in: "(a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) -⇩p set ps'"
hence ab_in': "(a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)" and "(a, b) ∉⇩p set ps'" by simp_all
show ?thesis
proof (cases "a = b")
case True
from ab_in' rec2.prems(2) have "b ∈ set hs" unfolding True in_pair_iff set_diff_list by auto
hence "fst b ∈ fst ` set hs" by fastforce
from this hs_sub have "fst b ∈ dgrad_p_set d m" ..
with assms(3) show ?thesis unfolding True by (rule crit_pair_cbelow_same)
next
case False
from ap assms(3) B_sup B_sub ab_in' ps_sps_sub uid' assms(5) False ‹fst a ≠ 0› ‹fst b ≠ 0›
show ?thesis
proof (rule ap_specD2)
fix x y :: "('t, 'b, 'c) pdata"
assume "(x, y) ∈⇩p set (ap gs bs (ps -- sps) hs data')"
also from ap_sub have "... ⊆ (set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)"
by (simp only: ab_specD1[OF ab] Un_assoc)
also have "... ⊆ (set gs ∪ set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)" by fastforce
finally have "(x, y) ∈ (set gs ∪ set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)"
unfolding in_pair_same .
hence "x ∈ set gs ∪ set bs ∪ set hs" and "y ∈ set gs ∪ set bs ∪ set hs" by simp_all
moreover from ‹(x, y) ∈⇩p set (ap gs bs (ps -- sps) hs data')› have "(x, y) ∉⇩p ?X -⇩p set ps'"
by (simp add: ps'_def)
moreover assume "fst x ≠ 0" and "fst y ≠ 0"
ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" by (rule c)
next
fix x y :: "('t, 'b, 'c) pdata"
assume "fst x ≠ 0" and "fst y ≠ 0"
assume 1: "x ∈ set gs ∪ set bs" and 2: "y ∈ set gs ∪ set bs"
hence x_in: "x ∈ set gs ∪ set bs ∪ set hs" and y_in: "y ∈ set gs ∪ set bs ∪ set hs" by simp_all
show "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)"
proof (cases "(x, y) ∈⇩p set (ps -- sps) -⇩p set ps'")
case True
with ‹fst x ≠ 0› ‹fst y ≠ 0› show ?thesis by (rule a)
next
case False
have "(x, y) ∉⇩p set (ps -- sps) ∪ set hs × (set gs ∪ set bs ∪ set hs) -⇩p set ps'"
proof
assume "(x, y) ∈⇩p set (ps -- sps) ∪ set hs × (set gs ∪ set bs ∪ set hs) -⇩p set ps'"
hence "(x, y) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)" using False
by simp
hence "x ∈ set hs ∨ y ∈ set hs" by (auto simp: in_pair_iff)
with 1 2 disj1 show False by blast
qed
with x_in y_in show ?thesis using ‹fst x ≠ 0› ‹fst y ≠ 0› by (rule c)
qed
qed
qed
next
assume "(a, b) ∈⇩p set (ps -- sps) -⇩p set ps'"
with ‹fst a ≠ 0› ‹fst b ≠ 0› show ?thesis by (rule a)
qed
next
fix x y :: "('t, 'b, 'c) pdata"
let ?res = "gb_schema_dummy (rc, data') D' (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')"
assume "x ∈ set (fst ?res)" and "y ∈ set (fst ?res)" and "(x, y) ∉⇩p snd ?res" and "fst x ≠ 0" and "fst y ≠ 0"
thus "crit_pair_cbelow_on d m (fst ` set (fst ?res)) (fst x) (fst y)" by (rule rec2.prems(7))
qed
qed
corollary gb_schema_dummy_connectible:
assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "dickson_grading d"
and "fst ` set gs ⊆ dgrad_p_set d m" and "is_Groebner_basis (fst ` set gs)"
and "fst ` set bs ⊆ dgrad_p_set d m"
and "set ps ⊆ set bs × (set gs ∪ set bs)" and "D ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)"
and "set ps ∩⇩p D = {}" and "unique_idx (gs @ bs) (snd data)"
and "⋀p q. processed (p, q) (gs @ bs) ps ⟹ (p, q) ∉⇩p D ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs)) (fst p) (fst q)"
and "⋀B a b. set gs ∪ set bs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹ (a, b) ∈⇩p D ⟹
fst a ≠ 0 ⟹ fst b ≠ 0 ⟹
(⋀x y. x ∈ set gs ∪ set bs ⟹ y ∈ set gs ∪ set bs ⟹ ¬ (x, y) ∈⇩p D ⟹
fst x ≠ 0 ⟹ fst y ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)) ⟹
crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
assumes "f ∈ set (fst (gb_schema_dummy data D bs ps))"
and "g ∈ set (fst (gb_schema_dummy data D bs ps))"
and "fst f ≠ 0" and "fst g ≠ 0"
shows "crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst f) (fst g)"
proof (cases "∃xs. fst (gb_schema_dummy data D bs ps) = full_gb xs")
case True
then obtain xs where xs: "fst (gb_schema_dummy data D bs ps) = full_gb xs" ..
note assms(3)
moreover have "fst ` set (full_gb xs) ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
have "dgrad_p_set_le d (fst ` set (full_gb xs)) (args_to_set (gs, bs, ps))"
unfolding xs[symmetric] using assms(3, 1) by (rule fst_gb_schema_dummy_dgrad_p_set_le)
also from assms(7) have "... = fst ` set gs ∪ fst ` set bs" by (rule args_to_set_subset_Times)
finally show "dgrad_p_set_le d (fst ` set (full_gb xs)) (fst ` set gs ∪ fst ` set bs)" .
next
from assms(4, 6) show "fst ` set gs ∪ fst ` set bs ⊆ dgrad_p_set d m" by blast
qed
moreover note full_gb_isGB
moreover from assms(13) have "fst f ∈ fst ` set (full_gb xs)" by (simp add: xs)
moreover from assms(14) have "fst g ∈ fst ` set (full_gb xs)" by (simp add: xs)
ultimately show ?thesis using assms(15, 16) unfolding xs
by (rule GB_imp_crit_pair_cbelow_dgrad_p_set)
next
case not_full: False
show ?thesis
proof (cases "(f, g) ∈⇩p snd (gb_schema_dummy data D bs ps)")
case True
from assms(1-10,12) _ not_full True assms(15,16) show ?thesis
proof (rule gb_schema_dummy_connectible2)
fix x y
assume "x ∈ set (fst (gb_schema_dummy data D bs ps))"
and "y ∈ set (fst (gb_schema_dummy data D bs ps))"
and "(x, y) ∉⇩p snd (gb_schema_dummy data D bs ps)"
and "fst x ≠ 0" and "fst y ≠ 0"
with assms(1-7,10,11) not_full
show "crit_pair_cbelow_on d m (fst ` set (fst (gb_schema_dummy data D bs ps))) (fst x) (fst y)"
by (rule gb_schema_dummy_connectible1)
qed
next
case False
from assms(1-7,10,11) not_full assms(13,14) False assms(15,16) show ?thesis
by (rule gb_schema_dummy_connectible1)
qed
qed
lemma fst_gb_schema_dummy_dgrad_p_set_le_init:
assumes "dickson_grading d" and "struct_spec sel ap ab compl"
shows "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy data D (ab gs [] bs (snd data)) (ap gs [] [] bs (snd data)))))
(fst ` (set gs ∪ set bs))"
proof -
let ?bs = "ab gs [] bs (snd data)"
from assms(2) have ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+
from ap_specD1[OF ap, of gs "[]" "[]" bs]
have *: "set (ap gs [] [] bs (snd data)) ⊆ set ?bs × (set gs ∪ set ?bs)"
by (simp add: ab_specD1[OF ab])
from assms have "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy data D ?bs (ap gs [] [] bs (snd data)))))
(args_to_set (gs, ?bs, (ap gs [] [] bs (snd data))))"
by (rule fst_gb_schema_dummy_dgrad_p_set_le)
also have "... = fst ` (set gs ∪ set bs)"
by (simp add: args_to_set_subset_Times[OF *] image_Un ab_specD1[OF ab])
finally show ?thesis .
qed
corollary fst_gb_schema_dummy_dgrad_p_set_init:
assumes "dickson_grading d" and "struct_spec sel ap ab compl"
and "fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m"
shows "fst ` set (fst (gb_schema_dummy (rc, data) D (ab gs [] bs data) (ap gs [] [] bs data))) ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set)
let ?data = "(rc, data)"
from assms(1, 2)
have "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy ?data D (ab gs [] bs (snd ?data)) (ap gs [] [] bs (snd ?data)))))
(fst ` (set gs ∪ set bs))"
by (rule fst_gb_schema_dummy_dgrad_p_set_le_init)
thus "dgrad_p_set_le d (fst ` set (fst (gb_schema_dummy ?data D (ab gs [] bs data) (ap gs [] [] bs data))))
(fst ` (set gs ∪ set bs))"
by (simp only: snd_conv)
qed fact
lemma fst_gb_schema_dummy_components_init:
fixes bs data
defines "bs0 ≡ ab gs [] bs data"
defines "ps0 ≡ ap gs [] [] bs data"
assumes "struct_spec sel ap ab compl"
shows "component_of_term ` Keys (fst ` set (fst (gb_schema_dummy (rc, data) D bs0 ps0))) =
component_of_term ` Keys (fst ` set (gs @ bs))" (is "?l = ?r")
proof -
from assms(3) have ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+
from ap_specD1[OF ap, of gs "[]" "[]" bs]
have *: "set ps0 ⊆ set bs0 × (set gs ∪ set bs0)" by (simp add: ps0_def bs0_def ab_specD1[OF ab])
with assms(3) have "?l = component_of_term ` Keys (args_to_set (gs, bs0, ps0))"
by (rule fst_gb_schema_dummy_components)
also have "... = ?r"
by (simp only: args_to_set_subset_Times[OF *], simp add: ab_specD1[OF ab] bs0_def image_Un)
finally show ?thesis .
qed
lemma fst_gb_schema_dummy_pmdl_init:
fixes bs data
defines "bs0 ≡ ab gs [] bs data"
defines "ps0 ≡ ap gs [] [] bs data"
assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)"
and "unique_idx (gs @ bs0) data" and "rem_comps_spec (gs @ bs0) (rc, data)"
shows "pmdl (fst ` set (fst (gb_schema_dummy (rc, data) D bs0 ps0))) =
pmdl (fst ` (set (gs @ bs)))" (is "?l = ?r")
proof -
from assms(3) have ab: "ab_spec ab" by (rule struct_specD3)
let ?data = "(rc, data)"
from assms(6) have "unique_idx (gs @ bs0) (snd ?data)" by (simp only: snd_conv)
from assms(3, 4, 5) _ this assms(7) have "?l = pmdl (fst ` (set (gs @ bs0)))"
proof (rule fst_gb_schema_dummy_pmdl)
from assms(3) have "ap_spec ap" by (rule struct_specD2)
from ap_specD1[OF this, of gs "[]" "[]" bs]
show "set ps0 ⊆ set bs0 × (set gs ∪ set bs0)" by (simp add: ps0_def bs0_def ab_specD1[OF ab])
qed
also have "... = ?r" by (simp add: bs0_def ab_specD1[OF ab])
finally show ?thesis .
qed
lemma fst_gb_schema_dummy_isGB_init:
fixes bs data
defines "bs0 ≡ ab gs [] bs data"
defines "ps0 ≡ ap gs [] [] bs data"
defines "D0 ≡ set bs × (set gs ∪ set bs) -⇩p set ps0"
assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "is_Groebner_basis (fst ` set gs)"
and "unique_idx (gs @ bs0) data" and "rem_comps_spec (gs @ bs0) (rc, data)"
shows "is_Groebner_basis (fst ` set (fst (gb_schema_dummy (rc, data) D0 bs0 ps0)))"
proof -
let ?data = "(rc, data)"
let ?res = "gb_schema_dummy ?data D0 bs0 ps0"
from assms(4) have ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD2, rule struct_specD3)
have set_bs0: "set bs0 = set bs" by (simp add: bs0_def ab_specD1[OF ab])
from ap_specD1[OF ap, of gs "[]" "[]" bs] have ps0_sub: "set ps0 ⊆ set bs0 × (set gs ∪ set bs0)"
by (simp add: ps0_def set_bs0)
from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" ..
have "finite (fst ` (set gs ∪ set bs))" by (rule, rule finite_UnI, fact finite_set, fact finite_set)
then obtain m where gs_bs_sub: "fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m" by (rule dgrad_p_set_exhaust)
with dg assms(4) have "fst ` set (fst ?res) ⊆ dgrad_p_set d m" unfolding bs0_def ps0_def
by (rule fst_gb_schema_dummy_dgrad_p_set_init)
with dg show ?thesis
proof (rule crit_pair_cbelow_imp_GB_dgrad_p_set)
fix p0 q0
assume p0_in: "p0 ∈ fst ` set (fst ?res)" and q0_in: "q0 ∈ fst ` set (fst ?res)"
assume "p0 ≠ 0" and "q0 ≠ 0"
from ‹fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m›
have "fst ` set gs ⊆ dgrad_p_set d m" and "fst ` set bs ⊆ dgrad_p_set d m"
by (simp_all add: image_Un)
from p0_in obtain p where p_in: "p ∈ set (fst ?res)" and p0: "p0 = fst p" ..
from q0_in obtain q where q_in: "q ∈ set (fst ?res)" and q0: "q0 = fst q" ..
from assms(7) have "unique_idx (gs @ bs0) (snd ?data)" by (simp only: snd_conv)
from assms(4, 5) dg ‹fst ` set gs ⊆ dgrad_p_set d m› assms(6) _ ps0_sub _ _ this _ _ p_in q_in ‹p0 ≠ 0› ‹q0 ≠ 0›
show "crit_pair_cbelow_on d m (fst ` set (fst ?res)) p0 q0" unfolding p0 q0
proof (rule gb_schema_dummy_connectible)
from ‹fst ` set bs ⊆ dgrad_p_set d m› show "fst ` set bs0 ⊆ dgrad_p_set d m"
by (simp only: set_bs0)
next
have "D0 ⊆ set bs × (set gs ∪ set bs)" by (auto simp: assms(3) minus_pairs_def)
also have "... ⊆ (set gs ∪ set bs) × (set gs ∪ set bs)" by fastforce
finally show "D0 ⊆ (set gs ∪ set bs0) × (set gs ∪ set bs0)" by (simp only: set_bs0)
next
show "set ps0 ∩⇩p D0 = {}"
proof
show "set ps0 ∩⇩p D0 ⊆ {}"
proof
fix x
assume "x ∈ set ps0 ∩⇩p D0"
hence "x ∈⇩p set ps0 ∩⇩p D0" by (simp add: in_pair_alt)
thus "x ∈ {}" by (auto simp: assms(3))
qed
qed simp
next
fix p' q'
assume "processed (p', q') (gs @ bs0) ps0"
hence proc: "processed (p', q') (gs @ bs) ps0"
by (simp add: set_bs0 processed_alt)
hence "p' ∈ set gs ∪ set bs" and "q' ∈ set gs ∪ set bs" and "(p', q') ∉⇩p set ps0"
by (auto dest: processedD1 processedD2 processedD3)
assume "(p', q') ∉⇩p D0" and "fst p' ≠ 0" and "fst q' ≠ 0"
have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs)) (fst p') (fst q')"
proof (cases "p' = q'")
case True
from dg show ?thesis unfolding True
proof (rule crit_pair_cbelow_same)
from ‹q' ∈ set gs ∪ set bs› have "fst q' ∈ fst ` (set gs ∪ set bs)" by simp
from this ‹fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m› show "fst q' ∈ dgrad_p_set d m" ..
qed
next
case False
show ?thesis
proof (cases "component_of_term (lt (fst p')) = component_of_term (lt (fst q'))")
case True
show ?thesis
proof (cases "p' ∈ set gs ∧ q' ∈ set gs")
case True
note dg ‹fst ` set gs ⊆ dgrad_p_set d m› assms(6)
moreover from True have "fst p' ∈ fst ` set gs" and "fst q' ∈ fst ` set gs" by simp_all
ultimately have "crit_pair_cbelow_on d m (fst ` set gs) (fst p') (fst q')"
using ‹fst p' ≠ 0› ‹fst q' ≠ 0› by (rule GB_imp_crit_pair_cbelow_dgrad_p_set)
moreover have "fst ` set gs ⊆ fst ` (set gs ∪ set bs)" by blast
ultimately show ?thesis by (rule crit_pair_cbelow_mono)
next
case False
with ‹p' ∈ set gs ∪ set bs› ‹q' ∈ set gs ∪ set bs›
have "(p', q') ∈⇩p set bs × (set gs ∪ set bs)" by (auto simp: in_pair_iff)
with ‹(p', q') ∉⇩p D0› have "(p', q') ∈⇩p set ps0" by (simp add: assms(3))
with ‹(p', q') ∉⇩p set ps0› show ?thesis ..
qed
next
case False
thus ?thesis by (rule crit_pair_cbelow_distinct_component)
qed
qed
thus "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs0)) (fst p') (fst q')"
by (simp only: set_bs0)
next
fix B a b
assume "set gs ∪ set bs0 ⊆ B"
hence B_sup: "set gs ∪ set bs ⊆ B" by (simp only: set_bs0)
assume B_sub: "fst ` B ⊆ dgrad_p_set d m"
assume "(a, b) ∈⇩p D0"
hence ab_in: "(a, b) ∈⇩p set bs × (set gs ∪ set bs)" and "(a, b) ∉⇩p set ps0"
by (simp_all add: assms(3))
assume "fst a ≠ 0" and "fst b ≠ 0"
assume *: "⋀x y. x ∈ set gs ∪ set bs0 ⟹ y ∈ set gs ∪ set bs0 ⟹ (x, y) ∉⇩p D0 ⟹
fst x ≠ 0 ⟹ fst y ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)"
show "crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
proof (cases "a = b")
case True
from ab_in have "b ∈ set gs ∪ set bs" unfolding True in_pair_iff set_diff_list by auto
hence "fst b ∈ fst ` (set gs ∪ set bs)" by fastforce
from this gs_bs_sub have "fst b ∈ dgrad_p_set d m" ..
with dg show ?thesis unfolding True by (rule crit_pair_cbelow_same)
next
case False
note ap dg
moreover from B_sup have B_sup': "set gs ∪ set [] ∪ set bs ⊆ B" by simp
moreover note B_sub
moreover from ab_in have "(a, b) ∈⇩p set bs × (set gs ∪ set [] ∪ set bs)" by simp
moreover have "set [] ⊆ set [] × (set gs ∪ set [])" by simp
moreover from assms(7) have "unique_idx (gs @ [] @ bs) data" by (simp add: unique_idx_def set_bs0)
ultimately show ?thesis using assms(6) False ‹fst a ≠ 0› ‹fst b ≠ 0›
proof (rule ap_specD2)
fix x y :: "('t, 'b, 'c) pdata"
assume "(x, y) ∈⇩p set (ap gs [] [] bs data)"
hence "(x, y) ∈⇩p set ps0" by (simp only: ps0_def)
also have "... ⊆ set bs0 × (set gs ∪ set bs0)" by (fact ps0_sub)
also have "... ⊆ (set gs ∪ set bs0) × (set gs ∪ set bs0)" by fastforce
finally have "(x, y) ∈ (set gs ∪ set bs0) × (set gs ∪ set bs0)" by (simp only: in_pair_same)
hence "x ∈ set gs ∪ set bs0" and "y ∈ set gs ∪ set bs0" by simp_all
moreover from ‹(x, y) ∈⇩p set ps0› have "(x, y) ∉⇩p D0" by (simp add: D0_def)
moreover assume "fst x ≠ 0" and "fst y ≠ 0"
ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)" by (rule *)
next
fix x y :: "('t, 'b, 'c) pdata"
assume "x ∈ set gs ∪ set []" and "y ∈ set gs ∪ set []"
hence "fst x ∈ fst ` set gs" and "fst y ∈ fst ` set gs" by simp_all
assume "fst x ≠ 0" and "fst y ≠ 0"
with dg ‹fst ` set gs ⊆ dgrad_p_set d m› assms(6) ‹fst x ∈ fst ` set gs› ‹fst y ∈ fst ` set gs›
have "crit_pair_cbelow_on d m (fst ` set gs) (fst x) (fst y)"
by (rule GB_imp_crit_pair_cbelow_dgrad_p_set)
moreover from B_sup have "fst ` set gs ⊆ fst ` B" by fastforce
ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst x) (fst y)"
by (rule crit_pair_cbelow_mono)
qed
qed
qed
qed
qed
subsubsection ‹Function ‹gb_schema_aux››
function (domintros) gb_schema_aux :: "nat × nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata list"
where
"gb_schema_aux data bs ps =
(if ps = [] then
gs @ bs
else
(let sps = sel gs bs ps (snd data); ps0 = ps -- sps; aux = compl gs bs ps0 sps (snd data);
remcomps = fst (data) - count_const_lt_components (fst aux) in
(if remcomps = 0 then
full_gb (gs @ bs)
else
let (hs, data') = add_indices aux (snd data) in
gb_schema_aux (remcomps, data') (ab gs bs hs data') (ap gs bs ps0 hs data')
)
)
)"
by pat_completeness auto
text ‹The ‹data› parameter of @{const gb_schema_aux} is a triple ‹(c, i, d)›, where ‹c› is the
number of components ‹cmp› of the input list for which the current basis ‹gs @ bs› does @{emph ‹not›}
yet contain an element whose leading power-product is ‹0› and has component ‹cmp›. As soon as ‹c›
gets ‹0›, the function can return a trivial Gr\"obner basis, since then the submodule generated by
the input list is just the full module. This idea generalizes the well-known fact that if a set of
scalar polynomials contains a non-zero constant, the ideal generated by that set is the whole ring.
‹i› is the total number of polynomials generated during the execution of the function so far; it
is used to attach unique indices to the polynomials for fast equality tests.
‹d›, finally, is some arbitrary data-field that may be used by concrete instances of
@{const gb_schema_aux} for storing information.›
lemma gb_schema_aux_domI1: "gb_schema_aux_dom (data, bs, [])"
by (rule gb_schema_aux.domintros, simp)
lemma gb_schema_aux_domI2:
assumes "struct_spec sel ap ab compl"
shows "gb_schema_aux_dom (data, args)"
proof -
from assms have sel: "sel_spec sel" and ap: "ap_spec ap" and ab: "ab_spec ab" by (rule struct_specD)+
from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" ..
let ?R = "gb_schema_aux_term d gs"
from dg have "wf ?R" by (rule gb_schema_aux_term_wf)
thus ?thesis
proof (induct args arbitrary: data rule: wf_induct_rule)
fix x data
assume IH: "⋀y data'. (y, x) ∈ ?R ⟹ gb_schema_aux_dom (data', y)"
obtain bs ps where x: "x = (bs, ps)" by (meson case_prodE case_prodI2)
show "gb_schema_aux_dom (data, x)" unfolding x
proof (rule gb_schema_aux.domintros)
fix rc0 n0 data0 hs n1 data1
assume "ps ≠ []"
and hs_data': "(hs, n1, data1) = add_indices (compl gs bs (ps -- sel gs bs ps (n0, data0))
(sel gs bs ps (n0, data0)) (n0, data0)) (n0, data0)"
and data: "data = (rc0, n0, data0)"
define sps where "sps = sel gs bs ps (n0, data0)"
define data' where "data' = (n1, data1)"
define rc where "rc = rc0 - count_const_lt_components (fst (compl gs bs (ps -- sel gs bs ps (n0, data0))
(sel gs bs ps (n0, data0)) (n0, data0)))"
from hs_data' have hs: "hs = fst (add_indices (compl gs bs (ps -- sps) sps (snd data)) (snd data))"
unfolding sps_def data snd_conv by (metis fstI)
show "gb_schema_aux_dom ((rc, data'), ab gs bs hs data', ap gs bs (ps -- sps) hs data')"
proof (rule IH, simp add: x gb_schema_aux_term_def gb_schema_aux_term1_def gb_schema_aux_term2_def, intro conjI)
show "fst ` set (ab gs bs hs data') ⊐p fst ` set bs ∨
ab gs bs hs data' = bs ∧ card (set (ap gs bs (ps -- sps) hs data')) < card (set ps)"
proof (cases "hs = []")
case True
have "ab gs bs hs data' = bs ∧ card (set (ap gs bs (ps -- sps) hs data')) < card (set ps)"
proof (simp only: True, rule)
from ab show "ab gs bs [] data' = bs" by (rule ab_specD2)
next
from sel ‹ps ≠ []› have "sps ≠ []" and "set sps ⊆ set ps"
unfolding sps_def by (rule sel_specD1, rule sel_specD2)
moreover from sel_specD1[OF sel ‹ps ≠ []›] have "set sps ≠ {}" by (simp add: sps_def)
ultimately have "set ps ∩ set sps ≠ {}" by (simp add: inf.absorb_iff2)
hence "set (ps -- sps) ⊂ set ps" unfolding set_diff_list by fastforce
hence "card (set (ps -- sps)) < card (set ps)" by (simp add: psubset_card_mono)
moreover have "card (set (ap gs bs (ps -- sps) [] data')) ≤ card (set (ps -- sps))"
by (rule card_mono, fact finite_set, rule ap_spec_Nil_subset, fact ap)
ultimately show "card (set (ap gs bs (ps -- sps) [] data')) < card (set ps)" by simp
qed
thus ?thesis ..
next
case False
with assms ‹ps ≠ []› sps_def hs have "fst ` set (ab gs bs hs data') ⊐p fst ` set bs"
unfolding data snd_conv by (rule struct_spec_red_supset)
thus ?thesis ..
qed
next
from dg assms ‹ps ≠ []› sps_def hs
show "dgrad_p_set_le d (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) (args_to_set (gs, bs, ps))"
unfolding data snd_conv by (rule dgrad_p_set_le_args_to_set_struct)
next
from assms ‹ps ≠ []› sps_def hs
show "component_of_term ` Keys (args_to_set (gs, ab gs bs hs data', ap gs bs (ps -- sps) hs data')) ⊆
component_of_term ` Keys (args_to_set (gs, bs, ps))"
unfolding data snd_conv by (rule components_subset_struct)
qed
qed
qed
qed
lemma gb_schema_aux_Nil [simp, code]: "gb_schema_aux data bs [] = gs @ bs"
by (simp add: gb_schema_aux.psimps[OF gb_schema_aux_domI1])
lemmas gb_schema_aux_simps = gb_schema_aux.psimps[OF gb_schema_aux_domI2]
lemma gb_schema_aux_induct [consumes 1, case_names base rec1 rec2]:
assumes "struct_spec sel ap ab compl"
assumes base: "⋀bs data. P data bs [] (gs @ bs)"
and rec1: "⋀bs ps sps data. ps ≠ [] ⟹ sps = sel gs bs ps (snd data) ⟹
fst (data) ≤ count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data))) ⟹
P data bs ps (full_gb (gs @ bs))"
and rec2: "⋀bs ps sps aux hs rc data data'. ps ≠ [] ⟹ sps = sel gs bs ps (snd data) ⟹
aux = compl gs bs (ps -- sps) sps (snd data) ⟹ (hs, data') = add_indices aux (snd data) ⟹
rc = fst data - count_const_lt_components (fst aux) ⟹ 0 < rc ⟹
P (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')
(gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')) ⟹
P data bs ps (gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))"
shows "P data bs ps (gb_schema_aux data bs ps)"
proof -
from assms(1) have "gb_schema_aux_dom (data, bs, ps)" by (rule gb_schema_aux_domI2)
thus ?thesis
proof (induct data bs ps rule: gb_schema_aux.pinduct)
case (1 data bs ps)
show ?case
proof (cases "ps = []")
case True
show ?thesis by (simp add: True, rule base)
next
case False
show ?thesis
proof (simp add: gb_schema_aux_simps[OF assms(1), of data bs ps] False Let_def split: if_split,
intro conjI impI)
define sps where "sps = sel gs bs ps (snd data)"
assume "fst data ≤ count_const_lt_components (fst (compl gs bs (ps -- sps) sps (snd data)))"
with False sps_def show "P data bs ps (full_gb (gs @ bs))" by (rule rec1)
next
define sps where "sps = sel gs bs ps (snd data)"
define aux where "aux = compl gs bs (ps -- sps) sps (snd data)"
define hs where "hs = fst (add_indices aux (snd data))"
define data' where "data' = snd (add_indices aux (snd data))"
define rc where "rc = fst data - count_const_lt_components (fst aux)"
have eq: "add_indices aux (snd data) = (hs, data')" by (simp add: hs_def data'_def)
assume "¬ fst data ≤ count_const_lt_components (fst aux)"
hence "0 < rc" by (simp add: rc_def)
hence "rc ≠ 0" by simp
show "P data bs ps
(case add_indices aux (snd data) of
(hs, data') ⇒ gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))"
unfolding eq prod.case using False sps_def aux_def eq[symmetric] rc_def ‹0 < rc›
proof (rule rec2)
show "P (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data')
(gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data'))"
using False sps_def refl aux_def rc_def ‹rc ≠ 0› eq[symmetric] refl by (rule 1)
qed
qed
qed
qed
qed
lemma gb_schema_dummy_eq_gb_schema_aux:
assumes "struct_spec sel ap ab compl"
shows "fst (gb_schema_dummy data D bs ps) = gb_schema_aux data bs ps"
using assms
proof (induct data D bs ps rule: gb_schema_dummy_induct)
case (base bs data D)
show ?case by simp
next
case (rec1 bs ps sps data D)
thus ?case by (simp add: gb_schema_aux.psimps[OF gb_schema_aux_domI2, OF assms])
next
case (rec2 bs ps sps aux hs rc data data' D D')
note rec2.hyps(8)
also from rec2.hyps(1, 2, 3) rec2.hyps(4)[symmetric] rec2.hyps(5, 6, 7)
have "gb_schema_aux (rc, data') (ab gs bs hs data') (ap gs bs (ps -- sps) hs data') =
gb_schema_aux data bs ps"
by (simp add: gb_schema_aux.psimps[OF gb_schema_aux_domI2, OF assms, of data] Let_def)
finally show ?case .
qed
corollary gb_schema_aux_dgrad_p_set_le:
assumes "dickson_grading d" and "struct_spec sel ap ab compl"
shows "dgrad_p_set_le d (fst ` set (gb_schema_aux data bs ps)) (args_to_set (gs, bs, ps))"
using fst_gb_schema_dummy_dgrad_p_set_le[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(2)] .
corollary gb_schema_aux_components:
assumes "struct_spec sel ap ab compl" and "set ps ⊆ set bs × (set gs ∪ set bs)"
shows "component_of_term ` Keys (fst ` set (gb_schema_aux data bs ps)) =
component_of_term ` Keys (args_to_set (gs, bs, ps))"
using fst_gb_schema_dummy_components[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(1)] .
lemma gb_schema_aux_pmdl:
assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)"
and "set ps ⊆ set bs × (set gs ∪ set bs)" and "unique_idx (gs @ bs) (snd data)"
and "rem_comps_spec (gs @ bs) data"
shows "pmdl (fst ` set (gb_schema_aux data bs ps)) = pmdl (fst ` set (gs @ bs))"
using fst_gb_schema_dummy_pmdl[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(1)] .
corollary gb_schema_aux_dgrad_p_set_le_init:
assumes "dickson_grading d" and "struct_spec sel ap ab compl"
shows "dgrad_p_set_le d (fst ` set (gb_schema_aux data (ab gs [] bs (snd data)) (ap gs [] [] bs (snd data))))
(fst ` (set gs ∪ set bs))"
using fst_gb_schema_dummy_dgrad_p_set_le_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(2)] .
corollary gb_schema_aux_dgrad_p_set_init:
assumes "dickson_grading d" and "struct_spec sel ap ab compl"
and "fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m"
shows "fst ` set (gb_schema_aux (rc, data) (ab gs [] bs data) (ap gs [] [] bs data)) ⊆ dgrad_p_set d m"
using fst_gb_schema_dummy_dgrad_p_set_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(2)] .
corollary gb_schema_aux_components_init:
assumes "struct_spec sel ap ab compl"
shows "component_of_term ` Keys (fst ` set (gb_schema_aux (rc, data) (ab gs [] bs data) (ap gs [] [] bs data))) =
component_of_term ` Keys (fst ` set (gs @ bs))"
using fst_gb_schema_dummy_components_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms] .
corollary gb_schema_aux_pmdl_init:
assumes "struct_spec sel ap ab compl" and "compl_pmdl compl" and "is_Groebner_basis (fst ` set gs)"
and "unique_idx (gs @ ab gs [] bs data) data" and "rem_comps_spec (gs @ ab gs [] bs data) (rc, data)"
shows "pmdl (fst ` set (gb_schema_aux (rc, data) (ab gs [] bs data) (ap gs [] [] bs data))) =
pmdl (fst ` (set (gs @ bs)))"
using fst_gb_schema_dummy_pmdl_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(1)] .
lemma gb_schema_aux_isGB_init:
assumes "struct_spec sel ap ab compl" and "compl_conn compl" and "is_Groebner_basis (fst ` set gs)"
and "unique_idx (gs @ ab gs [] bs data) data" and "rem_comps_spec (gs @ ab gs [] bs data) (rc, data)"
shows "is_Groebner_basis (fst ` set (gb_schema_aux (rc, data) (ab gs [] bs data) (ap gs [] [] bs data)))"
using fst_gb_schema_dummy_isGB_init[OF assms] unfolding gb_schema_dummy_eq_gb_schema_aux[OF assms(1)] .
end
subsubsection ‹Functions ‹gb_schema_direct› and ‹term gb_schema_incr››
definition gb_schema_direct :: "('t, 'b, 'c, 'd) selT ⇒ ('t, 'b, 'c, 'd) apT ⇒ ('t, 'b, 'c, 'd) abT ⇒
('t, 'b, 'c, 'd) complT ⇒ ('t, 'b, 'c) pdata' list ⇒ 'd ⇒
('t, 'b::field, 'c::default) pdata' list"
where "gb_schema_direct sel ap ab compl bs0 data0 =
(let data = (length bs0, data0); bs1 = fst (add_indices (bs0, data0) (0, data0));
bs = ab [] [] bs1 data in
map (λ(f, _, d). (f, d))
(gb_schema_aux sel ap ab compl [] (count_rem_components bs, data) bs (ap [] [] [] bs1 data))
)"
primrec gb_schema_incr :: "('t, 'b, 'c, 'd) selT ⇒ ('t, 'b, 'c, 'd) apT ⇒ ('t, 'b, 'c, 'd) abT ⇒
('t, 'b, 'c, 'd) complT ⇒
(('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata ⇒ 'd ⇒ 'd) ⇒
('t, 'b, 'c) pdata' list ⇒ 'd ⇒ ('t, 'b::field, 'c::default) pdata' list"
where
"gb_schema_incr _ _ _ _ _ [] _ = []"|
"gb_schema_incr sel ap ab compl upd (b0 # bs) data =
(let (gs, n, data') = add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data);
b = (fst b0, n, snd b0); data'' = upd gs b data' in
map (λ(f, _, d). (f, d))
(gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'')
(ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data'')))
)"
lemma (in -) fst_set_drop_indices:
"fst ` (λ(f, _, d). (f, d)) ` A = fst ` A" for A::"('x × 'y × 'z) set"
by (simp add: image_image, rule image_cong, fact refl, simp add: prod.case_eq_if)
lemma fst_gb_schema_direct:
"fst ` set (gb_schema_direct sel ap ab compl bs0 data0) =
(let data = (length bs0, data0); bs1 = fst (add_indices (bs0, data0) (0, data0)); bs = ab [] [] bs1 data in
fst ` set (gb_schema_aux sel ap ab compl [] (count_rem_components bs, data)
bs (ap [] [] [] bs1 data))
)"
by (simp add: gb_schema_direct_def Let_def fst_set_drop_indices)
lemma gb_schema_direct_dgrad_p_set:
assumes "dickson_grading d" and "struct_spec sel ap ab compl" and "fst ` set bs ⊆ dgrad_p_set d m"
shows "fst ` set (gb_schema_direct sel ap ab compl bs data) ⊆ dgrad_p_set d m"
unfolding fst_gb_schema_direct Let_def using assms(1, 2)
proof (rule gb_schema_aux_dgrad_p_set_init)
show "fst ` (set [] ∪ set (fst (add_indices (bs, data) (0, data)))) ⊆ dgrad_p_set d m"
using assms(3) by (simp add: image_Un fst_set_add_indices)
qed
theorem gb_schema_direct_isGB:
assumes "struct_spec sel ap ab compl" and "compl_conn compl"
shows "is_Groebner_basis (fst ` set (gb_schema_direct sel ap ab compl bs data))"
unfolding fst_gb_schema_direct Let_def using assms
proof (rule gb_schema_aux_isGB_init)
from is_Groebner_basis_empty show "is_Groebner_basis (fst ` set [])" by simp
next
let ?data = "(length bs, data)"
from assms(1) have "ab_spec ab" by (rule struct_specD)
moreover have "unique_idx ([] @ []) (0, data)" by (simp add: unique_idx_Nil)
ultimately show "unique_idx ([] @ ab [] [] (fst (add_indices (bs, data) (0, data))) ?data) ?data"
proof (rule unique_idx_ab)
show "(fst (add_indices (bs, data) (0, data)), length bs, data) = add_indices (bs, data) (0, data)"
by (simp add: add_indices_def)
qed
qed (simp add: rem_comps_spec_count_rem_components)
theorem gb_schema_direct_pmdl:
assumes "struct_spec sel ap ab compl" and "compl_pmdl compl"
shows "pmdl (fst ` set (gb_schema_direct sel ap ab compl bs data)) = pmdl (fst ` set bs)"
proof -
have "pmdl (fst ` set (gb_schema_direct sel ap ab compl bs data)) =
pmdl (fst ` set ([] @ (fst (add_indices (bs, data) (0, data)))))"
unfolding fst_gb_schema_direct Let_def using assms
proof (rule gb_schema_aux_pmdl_init)
from is_Groebner_basis_empty show "is_Groebner_basis (fst ` set [])" by simp
next
let ?data = "(length bs, data)"
from assms(1) have "ab_spec ab" by (rule struct_specD)
moreover have "unique_idx ([] @ []) (0, data)" by (simp add: unique_idx_Nil)
ultimately show "unique_idx ([] @ ab [] [] (fst (add_indices (bs, data) (0, data))) ?data) ?data"
proof (rule unique_idx_ab)
show "(fst (add_indices (bs, data) (0, data)), length bs, data) = add_indices (bs, data) (0, data)"
by (simp add: add_indices_def)
qed
qed (simp add: rem_comps_spec_count_rem_components)
thus ?thesis by (simp add: fst_set_add_indices)
qed
lemma fst_gb_schema_incr:
"fst ` set (gb_schema_incr sel ap ab compl upd (b0 # bs) data) =
(let (gs, n, data') = add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data);
b = (fst b0, n, snd b0); data'' = upd gs b data' in
fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'')
(ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data'')))
)"
by (simp only: gb_schema_incr.simps Let_def prod.case_distrib[of set]
prod.case_distrib[of "image fst"] set_map fst_set_drop_indices)
lemma gb_schema_incr_dgrad_p_set:
assumes "dickson_grading d" and "struct_spec sel ap ab compl"
and "fst ` set bs ⊆ dgrad_p_set d m"
shows "fst ` set (gb_schema_incr sel ap ab compl upd bs data) ⊆ dgrad_p_set d m"
using assms(3)
proof (induct bs)
case Nil
show ?case by simp
next
case (Cons b0 bs)
from Cons(2) have 1: "fst b0 ∈ dgrad_p_set d m" and 2: "fst ` set bs ⊆ dgrad_p_set d m" by simp_all
show ?case
proof (simp only: fst_gb_schema_incr Let_def split: prod.splits, simp, intro allI impI)
fix gs n data'
assume "add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data) = (gs, n, data')"
hence gs: "gs = fst (add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data))" by simp
define b where "b = (fst b0, n, snd b0)"
define data'' where "data'' = upd gs b data'"
from assms(1, 2)
show "fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'')
(ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data''))) ⊆ dgrad_p_set d m"
proof (rule gb_schema_aux_dgrad_p_set_init)
from 1 Cons(1)[OF 2] show "fst ` (set gs ∪ set [b]) ⊆ dgrad_p_set d m"
by (simp add: gs fst_set_add_indices b_def)
qed
qed
qed
theorem gb_schema_incr_dgrad_p_set_isGB:
assumes "struct_spec sel ap ab compl" and "compl_conn compl"
shows "is_Groebner_basis (fst ` set (gb_schema_incr sel ap ab compl upd bs data))"
proof (induct bs)
case Nil
from is_Groebner_basis_empty show ?case by simp
next
case (Cons b0 bs)
show ?case
proof (simp only: fst_gb_schema_incr Let_def split: prod.splits, simp, intro allI impI)
fix gs n data'
assume *: "add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data) = (gs, n, data')"
hence gs: "gs = fst (add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data))" by simp
define b where "b = (fst b0, n, snd b0)"
define data'' where "data'' = upd gs b data'"
from assms(1) have ab: "ab_spec ab" by (rule struct_specD3)
from Cons have "is_Groebner_basis (fst ` set gs)" by (simp add: gs fst_set_add_indices)
with assms
show "is_Groebner_basis (fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'')
(ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data''))))"
proof (rule gb_schema_aux_isGB_init)
from ab show "unique_idx (gs @ ab gs [] [b] (Suc n, data'')) (Suc n, data'')"
proof (rule unique_idx_ab)
from unique_idx_Nil *[symmetric] have "unique_idx ([] @ gs) (n, data')"
by (rule unique_idx_append)
thus "unique_idx (gs @ []) (n, data')" by simp
next
show "([b], Suc n, data'') = add_indices ([b0], data'') (n, data')"
by (simp add: add_indices_def b_def)
qed
next
have "rem_comps_spec (b # gs) (count_rem_components (b # gs), Suc n, data'')"
by (fact rem_comps_spec_count_rem_components)
moreover have "set (b # gs) = set (gs @ ab gs [] [b] (Suc n, data''))"
by (simp add: ab_specD1[OF ab])
ultimately show "rem_comps_spec (gs @ ab gs [] [b] (Suc n, data''))
(count_rem_components (b # gs), Suc n, data'')"
by (simp only: rem_comps_spec_def)
qed
qed
qed
theorem gb_schema_incr_pmdl:
assumes "struct_spec sel ap ab compl" and "compl_conn compl" "compl_pmdl compl"
shows "pmdl (fst ` set (gb_schema_incr sel ap ab compl upd bs data)) = pmdl (fst ` set bs)"
proof (induct bs)
case Nil
show ?case by simp
next
case (Cons b0 bs)
show ?case
proof (simp only: fst_gb_schema_incr Let_def split: prod.splits, simp, intro allI impI)
fix gs n data'
assume *: "add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data) = (gs, n, data')"
hence gs: "gs = fst (add_indices (gb_schema_incr sel ap ab compl upd bs data, data) (0, data))" by simp
define b where "b = (fst b0, n, snd b0)"
define data'' where "data'' = upd gs b data'"
from assms(1) have ab: "ab_spec ab" by (rule struct_specD3)
from assms(1, 2) have "is_Groebner_basis (fst ` set gs)" unfolding gs fst_conv fst_set_add_indices
by (rule gb_schema_incr_dgrad_p_set_isGB)
with assms(1, 3)
have eq: "pmdl (fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'')
(ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data'')))) =
pmdl (fst ` set (gs @ [b]))"
proof (rule gb_schema_aux_pmdl_init)
from ab show "unique_idx (gs @ ab gs [] [b] (Suc n, data'')) (Suc n, data'')"
proof (rule unique_idx_ab)
from unique_idx_Nil *[symmetric] have "unique_idx ([] @ gs) (n, data')"
by (rule unique_idx_append)
thus "unique_idx (gs @ []) (n, data')" by simp
next
show "([b], Suc n, data'') = add_indices ([b0], data'') (n, data')"
by (simp add: add_indices_def b_def)
qed
next
have "rem_comps_spec (b # gs) (count_rem_components (b # gs), Suc n, data'')"
by (fact rem_comps_spec_count_rem_components)
moreover have "set (b # gs) = set (gs @ ab gs [] [b] (Suc n, data''))"
by (simp add: ab_specD1[OF ab])
ultimately show "rem_comps_spec (gs @ ab gs [] [b] (Suc n, data''))
(count_rem_components (b # gs), Suc n, data'')"
by (simp only: rem_comps_spec_def)
qed
also have "... = pmdl (insert (fst b) (fst ` set gs))" by simp
also from Cons have "... = pmdl (insert (fst b) (fst ` set bs))"
unfolding gs fst_conv fst_set_add_indices by (rule pmdl.span_insert_cong)
finally show "pmdl (fst ` set (gb_schema_aux sel ap ab compl gs (count_rem_components (b # gs), Suc n, data'')
(ab gs [] [b] (Suc n, data'')) (ap gs [] [] [b] (Suc n, data'')))) =
pmdl (insert (fst b0) (fst ` set bs))" by (simp add: b_def)
qed
qed
subsection ‹Suitable Instances of the @{emph ‹add-pairs›} Parameter›
subsubsection ‹Specification of the @{emph ‹crit›} parameters›
type_synonym (in -) ('t, 'b, 'c, 'd) icritT = "nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata ⇒ ('t, 'b, 'c) pdata ⇒ bool"
type_synonym (in -) ('t, 'b, 'c, 'd) ncritT = "nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata list ⇒ bool ⇒
(bool × ('t, 'b, 'c) pdata_pair) list ⇒ ('t, 'b, 'c) pdata ⇒
('t, 'b, 'c) pdata ⇒ bool"
type_synonym (in -) ('t, 'b, 'c, 'd) ocritT = "nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒
(bool × ('t, 'b, 'c) pdata_pair) list ⇒ ('t, 'b, 'c) pdata ⇒
('t, 'b, 'c) pdata ⇒ bool"
definition icrit_spec :: "('t, 'b::field, 'c, 'd) icritT ⇒ bool"
where "icrit_spec crit ⟷
(∀d m data gs bs hs p q. dickson_grading d ⟶
fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m ⟶ unique_idx (gs @ bs @ hs) data ⟶
is_Groebner_basis (fst ` set gs) ⟶ p ∈ set hs ⟶ q ∈ set gs ∪ set bs ∪ set hs ⟶
fst p ≠ 0 ⟶ fst q ≠ 0 ⟶ crit data gs bs hs p q ⟶
crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q))"
text ‹Criteria satisfying @{const icrit_spec} can be used for discarding pairs @{emph ‹instantly›},
without reference to any other pairs.
The product criterion for scalar polynomials satisfies @{const icrit_spec}, and so does the
component criterion (which checks whether the component-indices of the leading terms of two
polynomials are identical).›
definition ncrit_spec :: "('t, 'b::field, 'c, 'd) ncritT ⇒ bool"
where "ncrit_spec crit ⟷
(∀d m data gs bs hs ps B q_in_bs p q. dickson_grading d ⟶ set gs ∪ set bs ∪ set hs ⊆ B ⟶
fst ` B ⊆ dgrad_p_set d m ⟶ snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs) ⟶
unique_idx (gs @ bs @ hs) data ⟶ is_Groebner_basis (fst ` set gs) ⟶
(q_in_bs ⟶ (q ∈ set gs ∪ set bs)) ⟶
(∀p' q'. (p', q') ∈⇩p snd ` set ps ⟶ fst p' ≠ 0 ⟶ fst q' ≠ 0 ⟶
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟶
(∀p' q'. p' ∈ set gs ∪ set bs ⟶ q' ∈ set gs ∪ set bs ⟶ fst p' ≠ 0 ⟶ fst q' ≠ 0 ⟶
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟶
p ∈ set hs ⟶ q ∈ set gs ∪ set bs ∪ set hs ⟶ fst p ≠ 0 ⟶ fst q ≠ 0 ⟶
crit data gs bs hs q_in_bs ps p q ⟶
crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q))"
definition ocrit_spec :: "('t, 'b::field, 'c, 'd) ocritT ⇒ bool"
where "ocrit_spec crit ⟷
(∀d m data hs ps B p q. dickson_grading d ⟶ set hs ⊆ B ⟶ fst ` B ⊆ dgrad_p_set d m ⟶
unique_idx (p # q # hs @ (map (fst ∘ snd) ps) @ (map (snd ∘ snd) ps)) data ⟶
(∀p' q'. (p', q') ∈⇩p snd ` set ps ⟶ fst p' ≠ 0 ⟶ fst q' ≠ 0 ⟶
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟶
p ∈ B ⟶ q ∈ B ⟶ fst p ≠ 0 ⟶ fst q ≠ 0 ⟶
crit data hs ps p q ⟶ crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q))"
text ‹Criteria satisfying @{const ncrit_spec} can be used for discarding new pairs by reference to
new and old elements, whereas criteria satisfying @{const ocrit_spec} can be used for
discarding old pairs by reference to new elements @{emph ‹only›} (no existing ones!).
The chain criterion satisfies both @{const ncrit_spec} and @{const ocrit_spec}.›
lemma icrit_specI:
assumes "⋀d m data gs bs hs p q.
dickson_grading d ⟹ fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m ⟹
unique_idx (gs @ bs @ hs) data ⟹ is_Groebner_basis (fst ` set gs) ⟹
p ∈ set hs ⟹ q ∈ set gs ∪ set bs ∪ set hs ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹
crit data gs bs hs p q ⟹
crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)"
shows "icrit_spec crit"
unfolding icrit_spec_def using assms by auto
lemma icrit_specD:
assumes "icrit_spec crit" and "dickson_grading d"
and "fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m" and "unique_idx (gs @ bs @ hs) data"
and "is_Groebner_basis (fst ` set gs)" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs"
and "fst p ≠ 0" and "fst q ≠ 0" and "crit data gs bs hs p q"
shows "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)"
using assms unfolding icrit_spec_def by blast
lemma ncrit_specI:
assumes "⋀d m data gs bs hs ps B q_in_bs p q.
dickson_grading d ⟹ set gs ∪ set bs ∪ set hs ⊆ B ⟹
fst ` B ⊆ dgrad_p_set d m ⟹ snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs) ⟹
unique_idx (gs @ bs @ hs) data ⟹ is_Groebner_basis (fst ` set gs) ⟹
(q_in_bs ⟶ q ∈ set gs ∪ set bs) ⟹
(⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟹
(⋀p' q'. p' ∈ set gs ∪ set bs ⟹ q' ∈ set gs ∪ set bs ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟹
p ∈ set hs ⟹ q ∈ set gs ∪ set bs ∪ set hs ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹
crit data gs bs hs q_in_bs ps p q ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
shows "ncrit_spec crit"
unfolding ncrit_spec_def by (intro allI impI, rule assms, assumption+, meson, meson, assumption+)
lemma ncrit_specD:
assumes "ncrit_spec crit" and "dickson_grading d" and "set gs ∪ set bs ∪ set hs ⊆ B"
and "fst ` B ⊆ dgrad_p_set d m" and "snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)"
and "unique_idx (gs @ bs @ hs) data" and "is_Groebner_basis (fst ` set gs)"
and "q_in_bs ⟹ q ∈ set gs ∪ set bs"
and "⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
and "⋀p' q'. p' ∈ set gs ∪ set bs ⟹ q' ∈ set gs ∪ set bs ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" and "fst p ≠ 0" and "fst q ≠ 0"
and "crit data gs bs hs q_in_bs ps p q"
shows "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
using assms unfolding ncrit_spec_def by blast
lemma ocrit_specI:
assumes "⋀d m data hs ps B p q.
dickson_grading d ⟹ set hs ⊆ B ⟹ fst ` B ⊆ dgrad_p_set d m ⟹
unique_idx (p # q # hs @ (map (fst ∘ snd) ps) @ (map (snd ∘ snd) ps)) data ⟹
(⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')) ⟹
p ∈ B ⟹ q ∈ B ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹
crit data hs ps p q ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
shows "ocrit_spec crit"
unfolding ocrit_spec_def by (intro allI impI, rule assms, assumption+, meson, assumption+)
lemma ocrit_specD:
assumes "ocrit_spec crit" and "dickson_grading d" and "set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m"
and "unique_idx (p # q # hs @ (map (fst ∘ snd) ps) @ (map (snd ∘ snd) ps)) data"
and "⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
and "p ∈ B" and "q ∈ B" and "fst p ≠ 0" and "fst q ≠ 0"
and "crit data hs ps p q"
shows "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
using assms unfolding ocrit_spec_def by blast
subsubsection ‹Suitable instances of the @{emph ‹crit›} parameters›
definition component_crit :: "('t, 'b::zero, 'c, 'd) icritT"
where "component_crit data gs bs hs p q ⟷ (component_of_term (lt (fst p)) ≠ component_of_term (lt (fst q)))"
lemma icrit_spec_component_crit: "icrit_spec (component_crit::('t, 'b::field, 'c, 'd) icritT)"
proof (rule icrit_specI)
fix d m and data::"nat × 'd" and gs bs hs and p q::"('t, 'b, 'c) pdata"
assume "component_crit data gs bs hs p q"
hence "component_of_term (lt (fst p)) ≠ component_of_term (lt (fst q))"
by (simp add: component_crit_def)
thus "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)"
by (rule crit_pair_cbelow_distinct_component)
qed
text ‹The product criterion is only applicable to scalar polynomials.›
definition product_crit :: "('a, 'b::zero, 'c, 'd) icritT"
where "product_crit data gs bs hs p q ⟷ (gcs (punit.lt (fst p)) (punit.lt (fst q)) = 0)"
lemma (in gd_term) icrit_spec_product_crit: "punit.icrit_spec (product_crit::('a, 'b::field, 'c, 'd) icritT)"
proof (rule punit.icrit_specI)
fix d m and data::"nat × 'd" and gs bs hs and p q::"('a, 'b, 'c) pdata"
assume "product_crit data gs bs hs p q"
hence *: "gcs (punit.lt (fst p)) (punit.lt (fst q)) = 0" by (simp only: product_crit_def)
assume "p ∈ set hs" and q_in: "q ∈ set gs ∪ set bs ∪ set hs" (is "_ ∈ ?B")
assume "dickson_grading d" and sub: "fst ` (set gs ∪ set bs ∪ set hs) ⊆ punit.dgrad_p_set d m"
moreover from ‹p ∈ set hs› have "fst p ∈ fst ` ?B" by simp
moreover from q_in have "fst q ∈ fst ` ?B" by simp
moreover assume "fst p ≠ 0" and "fst q ≠ 0"
ultimately show "punit.crit_pair_cbelow_on d m (fst ` ?B) (fst p) (fst q)"
using * by (rule product_criterion)
qed
text ‹@{const component_crit} and @{const product_crit} ignore the ‹data› parameter.›
fun (in -) pair_in_list :: "(bool × ('a, 'b, 'c) pdata_pair) list ⇒ nat ⇒ nat ⇒ bool" where
"pair_in_list [] _ _ = False"
|"pair_in_list ((_, (_, i', _), (_, j', _)) # ps) i j =
((i = i' ∧ j = j') ∨ (i = j' ∧ j = i') ∨ pair_in_list ps i j)"
lemma (in -) pair_in_listE:
assumes "pair_in_list ps i j"
obtains p q a b where "((p, i, a), (q, j, b)) ∈⇩p snd ` set ps"
using assms
proof (induct ps i j arbitrary: thesis rule: pair_in_list.induct)
case (1 i j)
from 1(2) show ?case by simp
next
case (2 c p i' a q j' b ps i j)
from 2(3) have "(i = i' ∧ j = j') ∨ (i = j' ∧ j = i') ∨ pair_in_list ps i j" by simp
thus ?case
proof (elim disjE conjE)
assume "i = i'" and "j = j'"
have "((p, i, a), (q, j, b)) ∈⇩p snd ` set ((c, (p, i', a), q, j', b) # ps)"
unfolding ‹i = i'› ‹j = j'› in_pair_iff by fastforce
thus ?thesis by (rule 2(2))
next
assume "i = j'" and "j = i'"
have "((q, i, b), (p, j, a)) ∈⇩p snd ` set ((c, (p, i', a), q, j', b) # ps)"
unfolding ‹i = j'› ‹j = i'› in_pair_iff by fastforce
thus ?thesis by (rule 2(2))
next
assume "pair_in_list ps i j"
obtain p' q' a' b' where "((p', i, a'), (q', j, b')) ∈⇩p snd ` set ps"
by (rule 2(1), assumption, rule ‹pair_in_list ps i j›)
also have "... ⊆ snd ` set ((c, (p, i', a), q, j', b) # ps)" by auto
finally show ?thesis by (rule 2(2))
qed
qed
definition chain_ncrit :: "('t, 'b::zero, 'c, 'd) ncritT"
where "chain_ncrit data gs bs hs q_in_bs ps p q ⟷
(let v = lt (fst p); l = term_of_pair (lcs (pp_of_term v) (lp (fst q)), component_of_term v);
i = fst (snd p); j = fst (snd q) in
(∃r∈set gs. let k = fst (snd r) in
k ≠ i ∧ k ≠ j ∧ lt (fst r) adds⇩t l ∧ pair_in_list ps i k ∧ (q_in_bs ∨ pair_in_list ps j k) ∧ fst r ≠ 0) ∨
(∃r∈set bs. let k = fst (snd r) in
k ≠ i ∧ k ≠ j ∧ lt (fst r) adds⇩t l ∧ pair_in_list ps i k ∧ (q_in_bs ∨ pair_in_list ps j k) ∧ fst r ≠ 0) ∨
(∃h∈set hs. let k = fst (snd h) in
k ≠ i ∧ k ≠ j ∧ lt (fst h) adds⇩t l ∧ pair_in_list ps i k ∧ pair_in_list ps j k ∧ fst h ≠ 0))"
definition chain_ocrit :: "('t, 'b::zero, 'c, 'd) ocritT"
where "chain_ocrit data hs ps p q ⟷
(let v = lt (fst p); l = term_of_pair (lcs (pp_of_term v) (lp (fst q)), component_of_term v);
i = fst (snd p); j = fst (snd q) in
(∃h∈set hs. let k = fst (snd h) in
k ≠ i ∧ k ≠ j ∧ lt (fst h) adds⇩t l ∧ pair_in_list ps i k ∧ pair_in_list ps j k ∧ fst h ≠ 0))"
text ‹@{const chain_ncrit} and @{const chain_ocrit} ignore the ‹data› parameter.›
lemma chain_ncritE:
assumes "chain_ncrit data gs bs hs q_in_bs ps p q" and "snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)"
and "unique_idx (gs @ bs @ hs) data" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs"
obtains r where "r ∈ set gs ∪ set bs ∪ set hs" and "fst r ≠ 0" and "r ≠ p" and "r ≠ q"
and "lt (fst r) adds⇩t term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))"
and "(p, r) ∈⇩p snd ` set ps" and "(r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ (q, r) ∈⇩p snd ` set ps"
proof -
let ?l = "term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))"
let ?i = "fst (snd p)"
let ?j = "fst (snd q)"
let ?xs = "gs @ bs @ hs"
have 3: "x ∈ set ?xs" if "(x, y) ∈⇩p snd ` set ps" for x y
proof -
note that
also have "snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (fact assms(2))
also have "... ⊆ (set gs ∪ set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)" by fastforce
finally have "(x, y) ∈ (set gs ∪ set bs ∪ set hs) × (set gs ∪ set bs ∪ set hs)"
by (simp only: in_pair_same)
thus ?thesis by simp
qed
have 4: "x ∈ set ?xs" if "(y, x) ∈⇩p snd ` set ps" for x y
proof -
from that have "(x, y) ∈⇩p snd ` set ps" by (simp add: in_pair_iff disj_commute)
thus ?thesis by (rule 3)
qed
from assms(1) have
"∃r ∈ set gs ∪ set bs ∪ set hs. let k = fst (snd r) in
k ≠ ?i ∧ k ≠ ?j ∧ lt (fst r) adds⇩t ?l ∧ pair_in_list ps ?i k ∧
((r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ pair_in_list ps ?j k) ∧ fst r ≠ 0"
by (smt UnI1 chain_ncrit_def sup_commute)
then obtain r where r_in: "r ∈ set gs ∪ set bs ∪ set hs" and "fst r ≠ 0" and rp: "fst (snd r) ≠ ?i"
and rq: "fst (snd r) ≠ ?j" and "lt (fst r) adds⇩t ?l"
and 1: "pair_in_list ps ?i (fst (snd r))"
and 2: "(r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ pair_in_list ps ?j (fst (snd r))"
unfolding Let_def by blast
let ?k = "fst (snd r)"
note r_in ‹fst r ≠ 0›
moreover from rp have "r ≠ p" by auto
moreover from rq have "r ≠ q" by auto
ultimately show ?thesis using ‹lt (fst r) adds⇩t ?l›
proof
from 1 obtain p' r' a b where *: "((p', ?i, a), (r', ?k, b)) ∈⇩p snd ` set ps"
by (rule pair_in_listE)
note assms(3)
moreover from * have "(p', ?i, a) ∈ set ?xs" by (rule 3)
moreover from assms(4) have "p ∈ set ?xs" by simp
moreover have "fst (snd (p', ?i, a)) = ?i" by simp
ultimately have p': "(p', ?i, a) = p" by (rule unique_idxD1)
note assms(3)
moreover from * have "(r', ?k, b) ∈ set ?xs" by (rule 4)
moreover from r_in have "r ∈ set ?xs" by simp
moreover have "fst (snd (r', ?k, b)) = ?k" by simp
ultimately have r': "(r', ?k, b) = r" by (rule unique_idxD1)
from * show "(p, r) ∈⇩p snd ` set ps" by (simp only: p' r')
next
from 2 show "(r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ (q, r) ∈⇩p snd ` set ps"
proof
assume "r ∈ set gs ∪ set bs ∧ q_in_bs"
thus ?thesis ..
next
assume "pair_in_list ps ?j ?k"
then obtain q' r' a b where *: "((q', ?j, a), (r', ?k, b)) ∈⇩p snd ` set ps"
by (rule pair_in_listE)
note assms(3)
moreover from * have "(q', ?j, a) ∈ set ?xs" by (rule 3)
moreover from assms(5) have "q ∈ set ?xs" by simp
moreover have "fst (snd (q', ?j, a)) = ?j" by simp
ultimately have q': "(q', ?j, a) = q" by (rule unique_idxD1)
note assms(3)
moreover from * have "(r', ?k, b) ∈ set ?xs" by (rule 4)
moreover from r_in have "r ∈ set ?xs" by simp
moreover have "fst (snd (r', ?k, b)) = ?k" by simp
ultimately have r': "(r', ?k, b) = r" by (rule unique_idxD1)
from * have "(q, r) ∈⇩p snd ` set ps" by (simp only: q' r')
thus ?thesis ..
qed
qed
qed
lemma chain_ocritE:
assumes "chain_ocrit data hs ps p q"
and "unique_idx (p # q # hs @ (map (fst ∘ snd) ps) @ (map (snd ∘ snd) ps)) data" (is "unique_idx ?xs _")
obtains h where "h ∈ set hs" and "fst h ≠ 0" and "h ≠ p" and "h ≠ q"
and "lt (fst h) adds⇩t term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))"
and "(p, h) ∈⇩p snd ` set ps" and "(q, h) ∈⇩p snd ` set ps"
proof -
let ?l = "term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))"
have 3: "x ∈ set ?xs" if "(x, y) ∈⇩p snd ` set ps" for x y
proof -
from that have "(x, y) ∈ snd ` set ps ∨ (y, x) ∈ snd ` set ps" by (simp only: in_pair_iff)
thus ?thesis
proof
assume "(x, y) ∈ snd ` set ps"
hence "fst (x, y) ∈ fst ` snd ` set ps" by fastforce
thus ?thesis by (simp add: image_comp)
next
assume "(y, x) ∈ snd ` set ps"
hence "snd (y, x) ∈ snd ` snd ` set ps" by fastforce
thus ?thesis by (simp add: image_comp)
qed
qed
have 4: "x ∈ set ?xs" if "(y, x) ∈⇩p snd ` set ps" for x y
proof -
from that have "(x, y) ∈⇩p snd ` set ps" by (simp add: in_pair_iff disj_commute)
thus ?thesis by (rule 3)
qed
from assms(1) obtain h where "h ∈ set hs" and "fst h ≠ 0" and hp: "fst (snd h) ≠ fst (snd p)"
and hq: "fst (snd h) ≠ fst (snd q)" and "lt (fst h) adds⇩t ?l"
and 1: "pair_in_list ps (fst (snd p)) (fst (snd h))" and 2: "pair_in_list ps (fst (snd q)) (fst (snd h))"
unfolding chain_ocrit_def Let_def by blast
let ?i = "fst (snd p)"
let ?j = "fst (snd q)"
let ?k = "fst (snd h)"
note ‹h ∈ set hs› ‹fst h ≠ 0›
moreover from hp have "h ≠ p" by auto
moreover from hq have "h ≠ q" by auto
ultimately show ?thesis using ‹lt (fst h) adds⇩t ?l›
proof
from 1 obtain p' h' a b where *: "((p', ?i, a), (h', ?k, b)) ∈⇩p snd ` set ps"
by (rule pair_in_listE)
note assms(2)
moreover from * have "(p', ?i, a) ∈ set ?xs" by (rule 3)
moreover have "p ∈ set ?xs" by simp
moreover have "fst (snd (p', ?i, a)) = ?i" by simp
ultimately have p': "(p', ?i, a) = p" by (rule unique_idxD1)
note assms(2)
moreover from * have "(h', ?k, b) ∈ set ?xs" by (rule 4)
moreover from ‹h ∈ set hs› have "h ∈ set ?xs" by simp
moreover have "fst (snd (h', ?k, b)) = ?k" by simp
ultimately have h': "(h', ?k, b) = h" by (rule unique_idxD1)
from * show "(p, h) ∈⇩p snd ` set ps" by (simp only: p' h')
next
from 2 obtain q' h' a b where *: "((q', ?j, a), (h', ?k, b)) ∈⇩p snd ` set ps"
by (rule pair_in_listE)
note assms(2)
moreover from * have "(q', ?j, a) ∈ set ?xs" by (rule 3)
moreover have "q ∈ set ?xs" by simp
moreover have "fst (snd (q', ?j, a)) = ?j" by simp
ultimately have q': "(q', ?j, a) = q" by (rule unique_idxD1)
note assms(2)
moreover from * have "(h', ?k, b) ∈ set ?xs" by (rule 4)
moreover from ‹h ∈ set hs› have "h ∈ set ?xs" by simp
moreover have "fst (snd (h', ?k, b)) = ?k" by simp
ultimately have h': "(h', ?k, b) = h" by (rule unique_idxD1)
from * show "(q, h) ∈⇩p snd ` set ps" by (simp only: q' h')
qed
qed
lemma ncrit_spec_chain_ncrit: "ncrit_spec (chain_ncrit::('t, 'b::field, 'c, 'd) ncritT)"
proof (rule ncrit_specI)
fix d m and data::"nat × 'd" and gs bs hs and ps::"(bool × ('t, 'b, 'c) pdata_pair) list"
and B q_in_bs and p q::"('t, 'b, 'c) pdata"
assume dg: "dickson_grading d" and B_sup: "set gs ∪ set bs ∪ set hs ⊆ B"
and B_sub: "fst ` B ⊆ dgrad_p_set d m" and q_in_bs: "q_in_bs ⟶ q ∈ set gs ∪ set bs"
and 1: "⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
and 2: "⋀p' q'. p' ∈ set gs ∪ set bs ⟹ q' ∈ set gs ∪ set bs ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
and "fst p ≠ 0" and "fst q ≠ 0"
let ?l = "term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))"
assume "chain_ncrit data gs bs hs q_in_bs ps p q" and "snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" and
"unique_idx (gs @ bs @ hs) data" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs"
then obtain r where "r ∈ set gs ∪ set bs ∪ set hs" and "fst r ≠ 0" and "r ≠ p" and "r ≠ q"
and adds: "lt (fst r) adds⇩t ?l" and "(p, r) ∈⇩p snd ` set ps"
and disj: "(r ∈ set gs ∪ set bs ∧ q_in_bs) ∨ (q, r) ∈⇩p snd ` set ps" by (rule chain_ncritE)
note dg B_sub
moreover from ‹p ∈ set hs› ‹q ∈ set gs ∪ set bs ∪ set hs› B_sup
have "fst p ∈ fst ` B" and "fst q ∈ fst ` B"
by auto
moreover note ‹fst p ≠ 0› ‹fst q ≠ 0›
moreover from adds have "lp (fst r) adds lcs (lp (fst p)) (lp (fst q))"
by (simp add: adds_term_def term_simps)
moreover from adds have "component_of_term (lt (fst r)) = component_of_term (lt (fst p))"
by (simp add: adds_term_def term_simps)
ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
proof (rule chain_criterion)
from ‹(p, r) ∈⇩p snd ` set ps› ‹fst p ≠ 0› ‹fst r ≠ 0›
show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst r)" by (rule 1)
next
from disj show "crit_pair_cbelow_on d m (fst ` B) (fst r) (fst q)"
proof
assume "r ∈ set gs ∪ set bs ∧ q_in_bs"
hence "r ∈ set gs ∪ set bs" and q_in_bs by simp_all
from q_in_bs this(2) have "q ∈ set gs ∪ set bs" ..
with ‹r ∈ set gs ∪ set bs› show ?thesis using ‹fst r ≠ 0› ‹fst q ≠ 0› by (rule 2)
next
assume "(q, r) ∈⇩p snd ` set ps"
hence "(r, q) ∈⇩p snd ` set ps" by (simp only: in_pair_iff disj_commute)
thus ?thesis using ‹fst r ≠ 0› ‹fst q ≠ 0› by (rule 1)
qed
qed
qed
lemma ocrit_spec_chain_ocrit: "ocrit_spec (chain_ocrit::('t, 'b::field, 'c, 'd) ocritT)"
proof (rule ocrit_specI)
fix d m and data::"nat × 'd" and hs::"('t, 'b, 'c) pdata list" and ps::"(bool × ('t, 'b, 'c) pdata_pair) list"
and B and p q::"('t, 'b, 'c) pdata"
assume dg: "dickson_grading d" and B_sup: "set hs ⊆ B"
and B_sub: "fst ` B ⊆ dgrad_p_set d m"
and 1: "⋀p' q'. (p', q') ∈⇩p snd ` set ps ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
and "fst p ≠ 0" and "fst q ≠ 0" and "p ∈ B" and "q ∈ B"
let ?l = "term_of_pair (lcs (lp (fst p)) (lp (fst q)), component_of_term (lt (fst p)))"
assume "chain_ocrit data hs ps p q" and "unique_idx (p # q # hs @ map (fst ∘ snd) ps @ map (snd ∘ snd) ps) data"
then obtain h where "h ∈ set hs" and "fst h ≠ 0" and "h ≠ p" and "h ≠ q"
and adds: "lt (fst h) adds⇩t ?l" and "(p, h) ∈⇩p snd ` set ps" and "(q, h) ∈⇩p snd ` set ps"
by (rule chain_ocritE)
note dg B_sub
moreover from ‹p ∈ B› ‹q ∈ B› B_sup
have "fst p ∈ fst ` B" and "fst q ∈ fst ` B" by auto
moreover note ‹fst p ≠ 0› ‹fst q ≠ 0›
moreover from adds have "lp (fst h) adds lcs (lp (fst p)) (lp (fst q))"
by (simp add: adds_term_def term_simps)
moreover from adds have "component_of_term (lt (fst h)) = component_of_term (lt (fst p))"
by (simp add: adds_term_def term_simps)
ultimately show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
proof (rule chain_criterion)
from ‹(p, h) ∈⇩p snd ` set ps› ‹fst p ≠ 0› ‹fst h ≠ 0›
show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst h)" by (rule 1)
next
from ‹(q, h) ∈⇩p snd ` set ps› have "(h, q) ∈⇩p snd ` set ps" by (simp only: in_pair_iff disj_commute)
thus "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst q)" using ‹fst h ≠ 0› ‹fst q ≠ 0› by (rule 1)
qed
qed
lemma icrit_spec_no_crit: "icrit_spec ((λ_ _ _ _ _ _. False)::('t, 'b::field, 'c, 'd) icritT)"
by (rule icrit_specI, simp)
lemma ncrit_spec_no_crit: "ncrit_spec ((λ_ _ _ _ _ _ _ _. False)::('t, 'b::field, 'c, 'd) ncritT)"
by (rule ncrit_specI, simp)
lemma ocrit_spec_no_crit: "ocrit_spec ((λ_ _ _ _ _. False)::('t, 'b::field, 'c, 'd) ocritT)"
by (rule ocrit_specI, simp)
subsubsection ‹Creating Initial List of New Pairs›
type_synonym (in -) ('t, 'b, 'c) apsT = "bool ⇒ ('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata ⇒ (bool × ('t, 'b, 'c) pdata_pair) list ⇒
(bool × ('t, 'b, 'c) pdata_pair) list"
type_synonym (in -) ('t, 'b, 'c, 'd) npT = "('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata list ⇒ nat × 'd ⇒
(bool × ('t, 'b, 'c) pdata_pair) list"
definition np_spec :: "('t, 'b, 'c, 'd) npT ⇒ bool"
where "np_spec np ⟷ (∀gs bs hs data.
snd ` set (np gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∧
set hs × (set gs ∪ set bs) ⊆ snd ` set (np gs bs hs data) ∧
(∀a b. a ∈ set hs ⟶ b ∈ set hs ⟶ a ≠ b ⟶ (a, b) ∈⇩p snd ` set (np gs bs hs data)) ∧
(∀p q. (True, p, q) ∈ set (np gs bs hs data) ⟶ q ∈ set gs ∪ set bs))"
lemma np_specI:
assumes "⋀gs bs hs data.
snd ` set (np gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∧
set hs × (set gs ∪ set bs) ⊆ snd ` set (np gs bs hs data) ∧
(∀a b. a ∈ set hs ⟶ b ∈ set hs ⟶ a ≠ b ⟶ (a, b) ∈⇩p snd ` set (np gs bs hs data)) ∧
(∀p q. (True, p, q) ∈ set (np gs bs hs data) ⟶ q ∈ set gs ∪ set bs)"
shows "np_spec np"
unfolding np_spec_def using assms by meson
lemma np_specD1:
assumes "np_spec np"
shows "snd ` set (np gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs)"
using assms[unfolded np_spec_def, rule_format, of gs bs hs data] ..
lemma np_specD2:
assumes "np_spec np"
shows "set hs × (set gs ∪ set bs) ⊆ snd ` set (np gs bs hs data)"
using assms[unfolded np_spec_def, rule_format, of gs bs hs data] by auto
lemma np_specD3:
assumes "np_spec np" and "a ∈ set hs" and "b ∈ set hs" and "a ≠ b"
shows "(a, b) ∈⇩p snd ` set (np gs bs hs data)"
using assms(1)[unfolded np_spec_def, rule_format, of gs bs hs data] assms(2,3,4) by blast
lemma np_specD4:
assumes "np_spec np" and "(True, p, q) ∈ set (np gs bs hs data)"
shows "q ∈ set gs ∪ set bs"
using assms(1)[unfolded np_spec_def, rule_format, of gs bs hs data] assms(2) by blast
lemma np_specE:
assumes "np_spec np" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" and "p ≠ q"
assumes 1: "⋀q_in_bs. (q_in_bs, p, q) ∈ set (np gs bs hs data) ⟹ thesis"
assumes 2: "⋀p_in_bs. (p_in_bs, q, p) ∈ set (np gs bs hs data) ⟹ thesis"
shows thesis
proof (cases "q ∈ set gs ∪ set bs")
case True
with assms(2) have "(p, q) ∈ set hs × (set gs ∪ set bs)" by simp
also from assms(1) have "... ⊆ snd ` set (np gs bs hs data)" by (rule np_specD2)
finally obtain q_in_bs where "(q_in_bs, p, q) ∈ set (np gs bs hs data)" by fastforce
thus ?thesis by (rule 1)
next
case False
with assms(3) have "q ∈ set hs" by simp
from assms(1,2) this assms(4) have "(p, q) ∈⇩p snd ` set (np gs bs hs data)" by (rule np_specD3)
hence "(p, q) ∈ snd ` set (np gs bs hs data) ∨ (q, p) ∈ snd ` set (np gs bs hs data)"
by (simp only: in_pair_iff)
thus ?thesis
proof
assume "(p, q) ∈ snd ` set (np gs bs hs data)"
then obtain q_in_bs where "(q_in_bs, p, q) ∈ set (np gs bs hs data)" by fastforce
thus ?thesis by (rule 1)
next
assume "(q, p) ∈ snd ` set (np gs bs hs data)"
then obtain p_in_bs where "(p_in_bs, q, p) ∈ set (np gs bs hs data)" by fastforce
thus ?thesis by (rule 2)
qed
qed
definition add_pairs_single_naive :: "'d ⇒ ('t, 'b::zero, 'c) apsT"
where "add_pairs_single_naive data flag gs bs h ps = ps @ (map (λg. (flag, h, g)) gs) @ (map (λb. (flag, h, b)) bs)"
lemma set_add_pairs_single_naive:
"set (add_pairs_single_naive data flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))"
by (auto simp add: add_pairs_single_naive_def Let_def)
fun add_pairs_single_sorted :: "((bool × ('t, 'b, 'c) pdata_pair) ⇒ (bool × ('t, 'b, 'c) pdata_pair) ⇒ bool) ⇒
('t, 'b::zero, 'c) apsT" where
"add_pairs_single_sorted _ _ [] [] _ ps = ps"|
"add_pairs_single_sorted rel flag [] (b # bs) h ps =
add_pairs_single_sorted rel flag [] bs h (insort_wrt rel (flag, h, b) ps)"|
"add_pairs_single_sorted rel flag (g # gs) bs h ps =
add_pairs_single_sorted rel flag gs bs h (insort_wrt rel (flag, h, g) ps)"
lemma set_add_pairs_single_sorted:
"set (add_pairs_single_sorted rel flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))"
proof (induct gs arbitrary: ps)
case Nil
show ?case
proof (induct bs arbitrary: ps)
case Nil
show ?case by simp
next
case (Cons b bs)
show ?case by (simp add: Cons)
qed
next
case (Cons g gs)
show ?case by (simp add: Cons)
qed
primrec (in -) pairs :: "('t, 'b, 'c) apsT ⇒ bool ⇒ ('t, 'b, 'c) pdata list ⇒ (bool × ('t, 'b, 'c) pdata_pair) list"
where
"pairs _ _ [] = []"|
"pairs aps flag (x # xs) = aps flag [] xs x (pairs aps flag xs)"
lemma pairs_subset:
assumes "⋀gs bs h ps. set (aps flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))"
shows "set (pairs aps flag xs) ⊆ Pair flag ` (set xs × set xs)"
proof (induct xs)
case Nil
show ?case by simp
next
case (Cons x xs)
from Cons have "set (pairs aps flag xs) ⊆ Pair flag ` (set (x # xs) × set (x # xs))" by fastforce
moreover have "{x} × set xs ⊆ set (x # xs) × set (x # xs)" by fastforce
ultimately show ?case by (auto simp add: assms)
qed
lemma in_pairsI:
assumes "⋀gs bs h ps. set (aps flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))"
and "a ≠ b" and "a ∈ set xs" and "b ∈ set xs"
shows "(flag, a, b) ∈ set (pairs aps flag xs) ∨ (flag, b, a) ∈ set (pairs aps flag xs)"
using assms(3, 4)
proof (induct xs)
case Nil
thus ?case by simp
next
case (Cons x xs)
from Cons(3) have d: "b = x ∨ b ∈ set xs" by simp
from Cons(2) have "a = x ∨ a ∈ set xs" by simp
thus ?case
proof
assume "a = x"
with assms(2) have "b ≠ x" by simp
with d have "b ∈ set xs" by simp
hence "(flag, a, b) ∈ set (pairs aps flag (x # xs))" by (simp add: ‹a = x› assms(1))
thus ?thesis by simp
next
assume "a ∈ set xs"
from d show ?thesis
proof
assume "b = x"
from ‹a ∈ set xs› have "(flag, b, a) ∈ set (pairs aps flag (x # xs))" by (simp add: ‹b = x› assms(1))
thus ?thesis by simp
next
assume "b ∈ set xs"
with ‹a ∈ set xs› have "(flag, a, b) ∈ set (pairs aps flag xs) ∨ (flag, b, a) ∈ set (pairs aps flag xs)"
by (rule Cons(1))
thus ?thesis by (auto simp: assms(1))
qed
qed
qed
corollary in_pairsI':
assumes "⋀gs bs h ps. set (aps flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))"
and "a ∈ set xs" and "b ∈ set xs" and "a ≠ b"
shows "(a, b) ∈⇩p snd ` set (pairs aps flag xs)"
proof -
from assms(1,4,2,3) have "(flag, a, b) ∈ set (pairs aps flag xs) ∨ (flag, b, a) ∈ set (pairs aps flag xs)"
by (rule in_pairsI)
thus ?thesis
proof
assume "(flag, a, b) ∈ set (pairs aps flag xs)"
hence "snd (flag, a, b) ∈ snd ` set (pairs aps flag xs)" by fastforce
thus ?thesis by (simp add: in_pair_iff)
next
assume "(flag, b, a) ∈ set (pairs aps flag xs)"
hence "snd (flag, b, a) ∈ snd ` set (pairs aps flag xs)" by fastforce
thus ?thesis by (simp add: in_pair_iff)
qed
qed
definition new_pairs_naive :: "('t, 'b::zero, 'c, 'd) npT"
where "new_pairs_naive gs bs hs data =
fold (add_pairs_single_naive data True gs bs) hs (pairs (add_pairs_single_naive data) False hs)"
definition new_pairs_sorted :: "(nat × 'd ⇒ (bool × ('t, 'b, 'c) pdata_pair) ⇒ (bool × ('t, 'b, 'c) pdata_pair) ⇒ bool) ⇒
('t, 'b::zero, 'c, 'd) npT"
where "new_pairs_sorted rel gs bs hs data =
fold (add_pairs_single_sorted (rel data) True gs bs) hs (pairs (add_pairs_single_sorted (rel data)) False hs)"
lemma set_fold_aps:
assumes "⋀gs bs h ps. set (aps flag gs bs h ps) = set ps ∪ Pair flag ` ({h} × (set gs ∪ set bs))"
shows "set (fold (aps flag gs bs) hs ps) = Pair flag ` (set hs × (set gs ∪ set bs)) ∪ set ps"
proof (induct hs arbitrary: ps)
case Nil
show ?case by simp
next
case (Cons h hs)
show ?case by (auto simp add: Cons assms)
qed
lemma set_new_pairs_naive:
"set (new_pairs_naive gs bs hs data) =
Pair True ` (set hs × (set gs ∪ set bs)) ∪ set (pairs (add_pairs_single_naive data) False hs)"
proof -
have "set (new_pairs_naive gs bs hs data) =
Pair True ` (set hs × (set gs ∪ set bs)) ∪ set (pairs (add_pairs_single_naive data) False hs)"
unfolding new_pairs_naive_def by (rule set_fold_aps, fact set_add_pairs_single_naive)
thus ?thesis by (simp add: ac_simps)
qed
lemma set_new_pairs_sorted:
"set (new_pairs_sorted rel gs bs hs data) =
Pair True ` (set hs × (set gs ∪ set bs)) ∪ set (pairs (add_pairs_single_sorted (rel data)) False hs)"
proof -
have "set (new_pairs_sorted rel gs bs hs data) =
Pair True ` (set hs × (set gs ∪ set bs)) ∪ set (pairs (add_pairs_single_sorted (rel data)) False hs)"
unfolding new_pairs_sorted_def by (rule set_fold_aps, fact set_add_pairs_single_sorted)
thus ?thesis by (simp add: set_merge_wrt ac_simps)
qed
lemma (in -) fst_snd_Pair [simp]:
shows "fst ∘ Pair x = (λ_. x)" and "snd ∘ Pair x = id"
by auto
lemma np_spec_new_pairs_naive: "np_spec new_pairs_naive"
proof (rule np_specI)
fix gs bs hs :: "('t, 'b, 'c) pdata list" and data::"nat × 'd"
have 1: "set hs × (set gs ∪ set bs) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by fastforce
have "set (pairs (add_pairs_single_naive data) False hs) ⊆ Pair False ` (set hs × set hs)"
by (rule pairs_subset, simp add: set_add_pairs_single_naive)
hence "snd ` set (pairs (add_pairs_single_naive data) False hs) ⊆ snd ` Pair False ` (set hs × set hs)"
by (rule image_mono)
also have "... = set hs × set hs" by (simp add: image_comp)
finally have 2: "snd ` set (pairs (add_pairs_single_naive data) False hs) ⊆ set hs × (set gs ∪ set bs ∪ set hs)"
by fastforce
show "snd ` set (new_pairs_naive gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∧
set hs × (set gs ∪ set bs) ⊆ snd ` set (new_pairs_naive gs bs hs data) ∧
(∀a b. a ∈ set hs ⟶ b ∈ set hs ⟶ a ≠ b ⟶ (a, b) ∈⇩p snd ` set (new_pairs_naive gs bs hs data)) ∧
(∀p q. (True, p, q) ∈ set (new_pairs_naive gs bs hs data) ⟶ q ∈ set gs ∪ set bs)"
proof (intro conjI allI impI)
show "snd ` set (new_pairs_naive gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs)"
by (simp add: set_new_pairs_naive image_Un image_comp 1 2)
next
show "set hs × (set gs ∪ set bs) ⊆ snd ` set (new_pairs_naive gs bs hs data)"
by (simp add: set_new_pairs_naive image_Un image_comp)
next
fix a b
assume "a ∈ set hs" and "b ∈ set hs" and "a ≠ b"
with set_add_pairs_single_naive
have "(a, b) ∈⇩p snd ` set (pairs (add_pairs_single_naive data) False hs)"
by (rule in_pairsI')
thus "(a, b) ∈⇩p snd ` set (new_pairs_naive gs bs hs data)"
by (simp add: set_new_pairs_naive image_Un)
next
fix p q
assume "(True, p, q) ∈ set (new_pairs_naive gs bs hs data)"
hence "q ∈ set gs ∪ set bs ∨ (True, p, q) ∈ set (pairs (add_pairs_single_naive data) False hs)"
by (auto simp: set_new_pairs_naive)
thus "q ∈ set gs ∪ set bs"
proof
assume "(True, p, q) ∈ set (pairs (add_pairs_single_naive data) False hs)"
also from set_add_pairs_single_naive have "... ⊆ Pair False ` (set hs × set hs)"
by (rule pairs_subset)
finally show ?thesis by auto
qed
qed
qed
lemma np_spec_new_pairs_sorted: "np_spec (new_pairs_sorted rel)"
proof (rule np_specI)
fix gs bs hs :: "('t, 'b, 'c) pdata list" and data::"nat × 'd"
have 1: "set hs × (set gs ∪ set bs) ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by fastforce
have "set (pairs (add_pairs_single_sorted (rel data)) False hs) ⊆ Pair False ` (set hs × set hs)"
by (rule pairs_subset, simp add: set_add_pairs_single_sorted)
hence "snd ` set (pairs (add_pairs_single_sorted (rel data)) False hs) ⊆ snd ` Pair False ` (set hs × set hs)"
by (rule image_mono)
also have "... = set hs × set hs" by (simp add: image_comp)
finally have 2: "snd ` set (pairs (add_pairs_single_sorted (rel data)) False hs) ⊆ set hs × (set gs ∪ set bs ∪ set hs)"
by fastforce
show "snd ` set (new_pairs_sorted rel gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs) ∧
set hs × (set gs ∪ set bs) ⊆ snd ` set (new_pairs_sorted rel gs bs hs data) ∧
(∀a b. a ∈ set hs ⟶ b ∈ set hs ⟶ a ≠ b ⟶ (a, b) ∈⇩p snd ` set (new_pairs_sorted rel gs bs hs data)) ∧
(∀p q. (True, p, q) ∈ set (new_pairs_sorted rel gs bs hs data) ⟶ q ∈ set gs ∪ set bs)"
proof (intro conjI allI impI)
show "snd ` set (new_pairs_sorted rel gs bs hs data) ⊆ set hs × (set gs ∪ set bs ∪ set hs)"
by (simp add: set_new_pairs_sorted image_Un image_comp 1 2)
next
show "set hs × (set gs ∪ set bs) ⊆ snd ` set (new_pairs_sorted rel gs bs hs data)"
by (simp add: set_new_pairs_sorted image_Un image_comp)
next
fix a b
assume "a ∈ set hs" and "b ∈ set hs" and "a ≠ b"
with set_add_pairs_single_sorted
have "(a, b) ∈⇩p snd ` set (pairs (add_pairs_single_sorted (rel data)) False hs)"
by (rule in_pairsI')
thus "(a, b) ∈⇩p snd ` set (new_pairs_sorted rel gs bs hs data)"
by (simp add: set_new_pairs_sorted image_Un)
next
fix p q
assume "(True, p, q) ∈ set (new_pairs_sorted rel gs bs hs data)"
hence "q ∈ set gs ∪ set bs ∨ (True, p, q) ∈ set (pairs (add_pairs_single_sorted (rel data)) False hs)"
by (auto simp: set_new_pairs_sorted)
thus "q ∈ set gs ∪ set bs"
proof
assume "(True, p, q) ∈ set (pairs (add_pairs_single_sorted (rel data)) False hs)"
also from set_add_pairs_single_sorted have "... ⊆ Pair False ` (set hs × set hs)"
by (rule pairs_subset)
finally show ?thesis by auto
qed
qed
qed
text ‹@{term "new_pairs_naive gs bs hs data"} and @{term "new_pairs_sorted rel gs bs hs data"} return
lists of triples @{term "(q_in_bs, p, q)"}, where ‹q_in_bs› indicates whether ‹q› is contained in
the list @{term "gs @ bs"} or in the list ‹hs›. ‹p› is always contained in ‹hs›.›
definition canon_pair_order_aux :: "('t, 'b::zero, 'c) pdata_pair ⇒ ('t, 'b, 'c) pdata_pair ⇒ bool"
where "canon_pair_order_aux p q ⟷
(lcs (lp (fst (fst p))) (lp (fst (snd p))) ≼ lcs (lp (fst (fst q))) (lp (fst (snd q))))"
abbreviation "canon_pair_order data p q ≡ canon_pair_order_aux (snd p) (snd q)"
abbreviation "canon_pair_comb ≡ merge_wrt canon_pair_order_aux"
subsubsection ‹Applying Criteria to New Pairs›
definition apply_icrit :: "('t, 'b, 'c, 'd) icritT ⇒ (nat × 'd) ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒
(bool × ('t, 'b, 'c) pdata_pair) list ⇒
(bool × bool × ('t, 'b, 'c) pdata_pair) list"
where "apply_icrit crit data gs bs hs ps = (let c = crit data gs bs hs in map (λ(q_in_bs, p, q). (c p q, q_in_bs, p, q)) ps)"
lemma fst_apply_icrit:
assumes "icrit_spec crit" and "dickson_grading d"
and "fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m" and "unique_idx (gs @ bs @ hs) data"
and "is_Groebner_basis (fst ` set gs)" and "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs"
and "fst p ≠ 0" and "fst q ≠ 0" and "(True, q_in_bs, p, q) ∈ set (apply_icrit crit data gs bs hs ps)"
shows "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)"
proof -
from assms(10) have "crit data gs bs hs p q" by (auto simp: apply_icrit_def)
with assms(1-9) show ?thesis by (rule icrit_specD)
qed
lemma snd_apply_icrit [simp]: "map snd (apply_icrit crit data gs bs hs ps) = ps"
by (auto simp add: apply_icrit_def case_prod_beta' intro: nth_equalityI)
lemma set_snd_apply_icrit [simp]: "snd ` set (apply_icrit crit data gs bs hs ps) = set ps"
proof -
have "snd ` set (apply_icrit crit data gs bs hs ps) = set (map snd (apply_icrit crit data gs bs hs ps))"
by (simp del: snd_apply_icrit)
also have "... = set ps" by (simp only: snd_apply_icrit)
finally show ?thesis .
qed
definition apply_ncrit :: "('t, 'b, 'c, 'd) ncritT ⇒ (nat × 'd) ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata list ⇒ ('t, 'b, 'c) pdata list ⇒
(bool × bool × ('t, 'b, 'c) pdata_pair) list ⇒
(bool × ('t, 'b, 'c) pdata_pair) list"
where "apply_ncrit crit data gs bs hs ps =
(let c = crit data gs bs hs in
rev (fold (λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps []))"
lemma apply_ncrit_append:
"apply_ncrit crit data gs bs hs (xs @ ys) =
rev (fold (λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ crit data gs bs hs q_in_bs ps' p q then ps' else (ic, p, q) # ps') ys
(rev (apply_ncrit crit data gs bs hs xs)))"
by (simp add: apply_ncrit_def Let_def)
lemma fold_superset:
"set acc ⊆
set (fold (λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps acc)"
proof (induct ps arbitrary: acc)
case Nil
show ?case by simp
next
case (Cons x ps)
obtain ic' q_in_bs' p' q' where x: "x = (ic', q_in_bs', p', q')" using prod_cases4 by blast
have 1: "set acc0 ⊆ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps acc0)"
for acc0 by (rule Cons)
have "set acc ⊆ set ((ic', p', q') # acc)" by fastforce
also have "... ⊆ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps
((ic', p', q') # acc))" by (fact 1)
finally have 2: "set acc ⊆ set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps
((ic', p', q') # acc))" .
show ?case by (simp add: x 1 2)
qed
lemma apply_ncrit_superset:
"set (apply_ncrit crit data gs bs hs ps) ⊆ set (apply_ncrit crit data gs bs hs (ps @ qs))" (is "?l ⊆ ?r")
proof -
have "?l = set (rev (apply_ncrit crit data gs bs hs ps))" by simp
also have "... ⊆ set (fold (λ(ic, q_in_bs, p, q) ps'.
if ¬ ic ∧ crit data gs bs hs q_in_bs ps' p q then ps' else (ic, p, q) # ps')
qs (rev (apply_ncrit crit data gs bs hs ps)))" by (fact fold_superset)
also have "... = ?r" by (simp add: apply_ncrit_append)
finally show ?thesis .
qed
lemma apply_ncrit_subset_aux:
assumes "(ic, p, q) ∈ set (fold
(λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps acc)"
shows "(ic, p, q) ∈ set acc ∨ (∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps)"
using assms
proof (induct ps arbitrary: acc)
case Nil
thus ?case by simp
next
case (Cons x ps)
obtain ic' q_in_bs' p' q' where x: "x = (ic', q_in_bs', p', q')" using prod_cases4 by blast
from Cons(2) have "(ic, p, q) ∈
set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ c q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps
(if ¬ ic' ∧ c q_in_bs' acc p' q' then acc else (ic', p', q') # acc))" by (simp add: x)
hence "(ic, p, q) ∈ set (if ¬ ic' ∧ c q_in_bs' acc p' q' then acc else (ic', p', q') # acc) ∨
(∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps)" by (rule Cons(1))
hence "(ic, p, q) ∈ set acc ∨ (ic, p, q) = (ic', p', q') ∨ (∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps)"
by (auto split: if_splits)
thus ?case
proof (elim disjE)
assume "(ic, p, q) ∈ set acc"
thus ?thesis ..
next
assume "(ic, p, q) = (ic', p', q')"
hence "x = (ic, q_in_bs', p, q)" by (simp add: x)
thus ?thesis by auto
next
assume "∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps"
then obtain q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps" ..
thus ?thesis by auto
qed
qed
corollary apply_ncrit_subset:
assumes "(ic, p, q) ∈ set (apply_ncrit crit data gs bs hs ps)"
obtains q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps"
proof -
from assms
have "(ic, p, q) ∈ set (fold
(λ(ic, q_in_bs, p, q). λps'. if ¬ ic ∧ crit data gs bs hs q_in_bs ps' p q then ps' else (ic, p, q) # ps') ps [])"
by (simp add: apply_ncrit_def)
hence "(ic, p, q) ∈ set [] ∨ (∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps)"
by (rule apply_ncrit_subset_aux)
hence "∃q_in_bs. (ic, q_in_bs, p, q) ∈ set ps" by simp
then obtain q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps" ..
thus ?thesis ..
qed
corollary apply_ncrit_subset': "snd ` set (apply_ncrit crit data gs bs hs ps) ⊆ snd ` snd ` set ps"
proof
fix p q
assume "(p, q) ∈ snd ` set (apply_ncrit crit data gs bs hs ps)"
then obtain ic where "(ic, p, q) ∈ set (apply_ncrit crit data gs bs hs ps)" by fastforce
then obtain q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps" by (rule apply_ncrit_subset)
thus "(p, q) ∈ snd ` snd ` set ps" by force
qed
lemma not_in_apply_ncrit:
assumes "(ic, p, q) ∉ set (apply_ncrit crit data gs bs hs (xs @ ((ic, q_in_bs, p, q) # ys)))"
shows "crit data gs bs hs q_in_bs (rev (apply_ncrit crit data gs bs hs xs)) p q"
using assms
proof (simp add: apply_ncrit_append split: if_splits)
assume "(ic, p, q) ∉
set (fold (λ(ic, q_in_bs, p, q) ps'. if ¬ ic ∧ crit data gs bs hs q_in_bs ps' p q then ps' else (ic, p, q) # ps')
ys ((ic, p, q) # rev (apply_ncrit crit data gs bs hs xs)))" (is "_ ∉ ?A")
have "(ic, p, q) ∈ set ((ic, p, q) # rev (apply_ncrit crit data gs bs hs xs))" by simp
also have "... ⊆ ?A" by (rule fold_superset)
finally have "(ic, p, q) ∈ ?A" .
with ‹(ic, p, q) ∉ ?A› show ?thesis ..
qed
lemma (in -) setE:
assumes "x ∈ set xs"
obtains ys zs where "xs = ys @ (x # zs)"
using assms
proof (induct xs arbitrary: thesis)
case Nil
from Nil(2) show ?case by simp
next
case (Cons a xs)
from Cons(3) have "x = a ∨ x ∈ set xs" by simp
thus ?case
proof
assume "x = a"
show ?thesis by (rule Cons(2)[of "[]" xs], simp add: ‹x = a›)
next
assume "x ∈ set xs"
then obtain ys zs where "xs = ys @ (x # zs)" by (meson Cons(1))
show ?thesis by (rule Cons(2)[of "a # ys" zs], simp add: ‹xs = ys @ (x # zs)›)
qed
qed
lemma apply_ncrit_connectible:
assumes "ncrit_spec crit" and "dickson_grading d"
and "set gs ∪ set bs ∪ set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m"
and "snd ` snd ` set ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)" and "unique_idx (gs @ bs @ hs) data"
and "is_Groebner_basis (fst ` set gs)"
and "⋀p' q'. (p', q') ∈ snd ` set (apply_ncrit crit data gs bs hs ps) ⟹
fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
and "⋀p' q'. p' ∈ set gs ∪ set bs ⟹ q' ∈ set gs ∪ set bs ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
assumes "(ic, q_in_bs, p, q) ∈ set ps" and "fst p ≠ 0" and "fst q ≠ 0"
and "q_in_bs ⟹ (q ∈ set gs ∪ set bs)"
shows "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
proof (cases "(p, q) ∈ snd ` set (apply_ncrit crit data gs bs hs ps)")
case True
thus ?thesis using assms(11,12) by (rule assms(8))
next
case False
from assms(10) have "(p, q) ∈ snd ` snd ` set ps" by force
also have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (fact assms(5))
finally have "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" by simp_all
from ‹(ic, q_in_bs, p, q) ∈ set ps› obtain xs ys where ps: "ps = xs @ ((ic, q_in_bs, p, q) # ys)"
by (rule setE)
let ?ps = "rev (apply_ncrit crit data gs bs hs xs)"
have "snd ` set ?ps ⊆ snd ` snd ` set xs" by (simp add: apply_ncrit_subset')
also have "... ⊆ snd ` snd ` set ps" unfolding ps by fastforce
finally have sub: "snd ` set ?ps ⊆ set hs × (set gs ∪ set bs ∪ set hs)"
using assms(5) by (rule subset_trans)
from False have "(p, q) ∉ snd ` set (apply_ncrit crit data gs bs hs ps)" by (simp add: in_pair_iff)
hence "(ic, p, q) ∉ set (apply_ncrit crit data gs bs hs (xs @ ((ic, q_in_bs, p, q) # ys)))"
unfolding ps by force
hence "crit data gs bs hs q_in_bs ?ps p q" by (rule not_in_apply_ncrit)
with assms(1-4) sub assms(6,7,13) _ _ ‹p ∈ set hs› ‹q ∈ set gs ∪ set bs ∪ set hs› assms(11,12)
show ?thesis
proof (rule ncrit_specD)
fix p' q'
assume "(p', q') ∈⇩p snd ` set ?ps"
also have "... ⊆ snd ` set (apply_ncrit crit data gs bs hs ps)"
by (rule image_mono, simp add: ps apply_ncrit_superset)
finally have disj: "(p', q') ∈ snd ` set (apply_ncrit crit data gs bs hs ps) ∨
(q', p') ∈ snd ` set (apply_ncrit crit data gs bs hs ps)" by (simp only: in_pair_iff)
assume "fst p' ≠ 0" and "fst q' ≠ 0"
from disj show "crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
proof
assume "(p', q') ∈ snd ` set (apply_ncrit crit data gs bs hs ps)"
thus ?thesis using ‹fst p' ≠ 0› ‹fst q' ≠ 0› by (rule assms(8))
next
assume "(q', p') ∈ snd ` set (apply_ncrit crit data gs bs hs ps)"
hence "crit_pair_cbelow_on d m (fst ` B) (fst q') (fst p')"
using ‹fst q' ≠ 0› ‹fst p' ≠ 0› by (rule assms(8))
thus ?thesis by (rule crit_pair_cbelow_sym)
qed
qed (assumption, fact assms(9))
qed
subsubsection ‹Applying Criteria to Old Pairs›
definition apply_ocrit :: "('t, 'b, 'c, 'd) ocritT ⇒ (nat × 'd) ⇒ ('t, 'b, 'c) pdata list ⇒
(bool × ('t, 'b, 'c) pdata_pair) list ⇒ ('t, 'b, 'c) pdata_pair list ⇒
('t, 'b, 'c) pdata_pair list"
where "apply_ocrit crit data hs ps' ps = (let c = crit data hs ps' in [(p, q)←ps . ¬ c p q])"
lemma set_apply_ocrit:
"set (apply_ocrit crit data hs ps' ps) = {(p, q) | p q. (p, q) ∈ set ps ∧ ¬ crit data hs ps' p q}"
by (auto simp: apply_ocrit_def)
corollary set_apply_ocrit_iff:
"(p, q) ∈ set (apply_ocrit crit data hs ps' ps) ⟷ ((p, q) ∈ set ps ∧ ¬ crit data hs ps' p q)"
by (auto simp: apply_ocrit_def)
lemma apply_ocrit_connectible:
assumes "ocrit_spec crit" and "dickson_grading d" and "set hs ⊆ B" and "fst ` B ⊆ dgrad_p_set d m"
and "unique_idx (p # q # hs @ (map (fst ∘ snd) ps') @ (map (snd ∘ snd) ps')) data"
and "⋀p' q'. (p', q') ∈ snd ` set ps' ⟹ fst p' ≠ 0 ⟹ fst q' ≠ 0 ⟹
crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
assumes "p ∈ B" and "q ∈ B" and "fst p ≠ 0" and "fst q ≠ 0"
and "(p, q) ∈ set ps" and "(p, q) ∉ set (apply_ocrit crit data hs ps' ps)"
shows "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
proof -
from assms(11,12) have "crit data hs ps' p q" by (simp add: set_apply_ocrit_iff)
with assms(1-5) _ assms(7-10) show ?thesis
proof (rule ocrit_specD)
fix p' q'
assume "(p', q') ∈⇩p snd ` set ps'"
hence disj: "(p', q') ∈ snd ` set ps' ∨ (q', p') ∈ snd ` set ps'" by (simp only: in_pair_iff)
assume "fst p' ≠ 0" and "fst q' ≠ 0"
from disj show "crit_pair_cbelow_on d m (fst ` B) (fst p') (fst q')"
proof
assume "(p', q') ∈ snd ` set ps'"
thus ?thesis using ‹fst p' ≠ 0› ‹fst q' ≠ 0› by (rule assms(6))
next
assume "(q', p') ∈ snd ` set ps'"
hence "crit_pair_cbelow_on d m (fst ` B) (fst q') (fst p')" using ‹fst q' ≠ 0› ‹fst p' ≠ 0›
by (rule assms(6))
thus ?thesis by (rule crit_pair_cbelow_sym)
qed
qed
qed
subsubsection ‹Creating Final List of Pairs›
context
fixes np::"('t, 'b::field, 'c, 'd) npT"
and icrit::"('t, 'b, 'c, 'd) icritT"
and ncrit::"('t, 'b, 'c, 'd) ncritT"
and ocrit::"('t, 'b, 'c, 'd) ocritT"
and comb::"('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata_pair list"
begin
definition add_pairs :: "('t, 'b, 'c, 'd) apT"
where "add_pairs gs bs ps hs data =
(let ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data));
ps2 = apply_ocrit ocrit data hs ps1 ps in comb (map snd [x←ps1 . ¬ fst x]) ps2)"
lemma set_add_pairs:
assumes "⋀xs ys. set (comb xs ys) = set xs ∪ set ys"
assumes "ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data))"
shows "set (add_pairs gs bs ps hs data) =
{(p, q) | p q. (False, p, q) ∈ set ps1 ∨ ((p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q)}"
proof -
have eq: "snd ` {x ∈ set ps1. ¬ fst x} = {(p, q) | p q. (False, p, q) ∈ set ps1}" by force
thus ?thesis by (auto simp: add_pairs_def Let_def assms(1) assms(2)[symmetric] set_apply_ocrit)
qed
lemma set_add_pairs_iff:
assumes "⋀xs ys. set (comb xs ys) = set xs ∪ set ys"
assumes "ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data))"
shows "((p, q) ∈ set (add_pairs gs bs ps hs data)) ⟷
((False, p, q) ∈ set ps1 ∨ ((p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q))"
proof -
from assms have eq: "set (add_pairs gs bs ps hs data) =
{(p, q) | p q. (False, p, q) ∈ set ps1 ∨ ((p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q)}"
by (rule set_add_pairs)
obtain a aa b where p: "p = (a, aa, b)" using prod_cases3 by blast
obtain ab ac ba where q: "q = (ab, ac, ba)" using prod_cases3 by blast
show ?thesis by (simp add: eq p q)
qed
lemma ap_spec_add_pairs:
assumes "np_spec np" and "icrit_spec icrit" and "ncrit_spec ncrit" and "ocrit_spec ocrit"
and "⋀xs ys. set (comb xs ys) = set xs ∪ set ys"
shows "ap_spec add_pairs"
proof (rule ap_specI)
fix gs bs :: "('t, 'b, 'c) pdata list" and ps hs and data::"nat × 'd"
define ps1 where "ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data))"
show "set (add_pairs gs bs ps hs data) ⊆ set ps ∪ set hs × (set gs ∪ set bs ∪ set hs)"
proof
fix p q
assume "(p, q) ∈ set (add_pairs gs bs ps hs data)"
with assms(5) ps1_def have "(False, p, q) ∈ set ps1 ∨ ((p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q)"
by (simp add: set_add_pairs_iff)
thus "(p, q) ∈ set ps ∪ set hs × (set gs ∪ set bs ∪ set hs)"
proof
assume "(False, p, q) ∈ set ps1"
hence "snd (False, p, q) ∈ snd ` set ps1" by fastforce
hence "(p, q) ∈ snd ` set ps1" by simp
also have "... ⊆ snd ` snd ` set (apply_icrit icrit data gs bs hs (np gs bs hs data))"
unfolding ps1_def by (fact apply_ncrit_subset')
also have "... = snd ` set (np gs bs hs data)" by simp
also from assms(1) have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (rule np_specD1)
finally show ?thesis ..
next
assume "(p, q) ∈ set ps ∧ ¬ ocrit data hs ps1 p q"
thus ?thesis by simp
qed
qed
next
fix gs bs :: "('t, 'b, 'c) pdata list" and ps hs and data::"nat × 'd" and B and d::"'a ⇒ nat" and m h g
assume dg: "dickson_grading d" and B_sup: "set gs ∪ set bs ∪ set hs ⊆ B"
and B_sub: "fst ` B ⊆ dgrad_p_set d m" and h_in: "h ∈ set hs" and g_in: "g ∈ set gs ∪ set bs ∪ set hs"
and ps_sub: "set ps ⊆ set bs × (set gs ∪ set bs)"
and uid: "unique_idx (gs @ bs @ hs) data" and gb: "is_Groebner_basis (fst ` set gs)" and "h ≠ g"
and "fst h ≠ 0" and "fst g ≠ 0"
assume a: "⋀a b. (a, b) ∈⇩p set (add_pairs gs bs ps hs data) ⟹
fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
assume b: "⋀a b. a ∈ set gs ∪ set bs ⟹
b ∈ set gs ∪ set bs ⟹
fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
define ps0 where "ps0 = apply_icrit icrit data gs bs hs (np gs bs hs data)"
define ps1 where "ps1 = apply_ncrit ncrit data gs bs hs ps0"
have "snd ` snd ` set ps0 = snd ` set (np gs bs hs data)" by (simp add: ps0_def)
also from assms(1) have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (rule np_specD1)
finally have ps0_sub: "snd ` snd ` set ps0 ⊆ set hs × (set gs ∪ set bs ∪ set hs)" .
have "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
if "(p, q) ∈ snd ` set ps1" and "fst p ≠ 0" and "fst q ≠ 0" for p q
proof -
from ‹(p, q) ∈ snd ` set ps1› obtain ic where "(ic, p, q) ∈ set ps1" by fastforce
show ?thesis
proof (cases "ic")
case True
from ‹(ic, p, q) ∈ set ps1› obtain q_in_bs where "(ic, q_in_bs, p, q) ∈ set ps0"
unfolding ps1_def by (rule apply_ncrit_subset)
with True have "(True, q_in_bs, p, q) ∈ set ps0" by simp
hence "snd (snd (True, q_in_bs, p, q)) ∈ snd ` snd ` set ps0" by fastforce
hence "(p, q) ∈ snd ` snd ` set ps0" by simp
also have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (fact ps0_sub)
finally have "p ∈ set hs" and "q ∈ set gs ∪ set bs ∪ set hs" by simp_all
from B_sup have B_sup': "fst ` (set gs ∪ set bs ∪ set hs) ⊆ fst ` B" by (rule image_mono)
hence "fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m" using B_sub by (rule subset_trans)
from assms(2) dg this uid gb ‹p ∈ set hs› ‹q ∈ set gs ∪ set bs ∪ set hs› ‹fst p ≠ 0› ‹fst q ≠ 0›
‹(True, q_in_bs, p, q) ∈ set ps0›
have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)"
unfolding ps0_def by (rule fst_apply_icrit)
thus ?thesis using B_sup' by (rule crit_pair_cbelow_mono)
next
case False
with ‹(ic, p, q) ∈ set ps1› have "(False, p, q) ∈ set ps1" by simp
with assms(5) ps1_def have "(p, q) ∈ set (add_pairs gs bs ps hs data)"
by (simp add: set_add_pairs_iff ps0_def)
hence "(p, q) ∈⇩p set (add_pairs gs bs ps hs data)" by (simp add: in_pair_iff)
thus ?thesis using ‹fst p ≠ 0› ‹fst q ≠ 0› by (rule a)
qed
qed
with assms(3) dg B_sup B_sub ps0_sub uid gb
have *: "(ic, q_in_bs, p, q) ∈ set ps0 ⟹ fst p ≠ 0 ⟹ fst q ≠ 0 ⟹
(q_in_bs ⟹ q ∈ set gs ∪ set bs) ⟹ crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
for ic q_in_bs p q using b unfolding ps1_def by (rule apply_ncrit_connectible)
show "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)"
proof (cases "h = g")
case True
from g_in B_sup have "g ∈ B" ..
hence "fst g ∈ fst ` B" by simp
hence "fst g ∈ dgrad_p_set d m" using B_sub ..
with dg show ?thesis unfolding True by (rule crit_pair_cbelow_same)
next
case False
with assms(1) h_in g_in show ?thesis
proof (rule np_specE)
fix g_in_bs
assume "(g_in_bs, h, g) ∈ set (np gs bs hs data)"
also have "... = snd ` set ps0" by (simp add: ps0_def)
finally obtain ic where "(ic, g_in_bs, h, g) ∈ set ps0" by fastforce
moreover note ‹fst h ≠ 0› ‹fst g ≠ 0›
moreover from assms(1) have "g ∈ set gs ∪ set bs" if "g_in_bs"
proof (rule np_specD4)
from ‹(g_in_bs, h, g) ∈ set (np gs bs hs data)› that show "(True, h, g) ∈ set (np gs bs hs data)"
by simp
qed
ultimately show ?thesis by (rule *)
next
fix h_in_bs
assume "(h_in_bs, g, h) ∈ set (np gs bs hs data)"
also have "... = snd ` set ps0" by (simp add: ps0_def)
finally obtain ic where "(ic, h_in_bs, g, h) ∈ set ps0" by fastforce
moreover note ‹fst g ≠ 0› ‹fst h ≠ 0›
moreover from assms(1) have "h ∈ set gs ∪ set bs" if "h_in_bs"
proof (rule np_specD4)
from ‹(h_in_bs, g, h) ∈ set (np gs bs hs data)› that show "(True, g, h) ∈ set (np gs bs hs data)"
by simp
qed
ultimately have "crit_pair_cbelow_on d m (fst ` B) (fst g) (fst h)" by (rule *)
thus ?thesis by (rule crit_pair_cbelow_sym)
qed
qed
next
fix gs bs :: "('t, 'b, 'c) pdata list" and ps hs and data::"nat × 'd" and B and d::"'a ⇒ nat" and m h g
define ps1 where "ps1 = apply_ncrit ncrit data gs bs hs (apply_icrit icrit data gs bs hs (np gs bs hs data))"
assume "(h, g) ∈ set ps -⇩p set (add_pairs gs bs ps hs data)"
hence "(h, g) ∈ set ps" and "(h, g) ∉⇩p set (add_pairs gs bs ps hs data)" by simp_all
from this(2) have "(h, g) ∉ set (add_pairs gs bs ps hs data)" by (simp add: in_pair_iff)
assume dg: "dickson_grading d" and B_sup: "set gs ∪ set bs ∪ set hs ⊆ B" and B_sub: "fst ` B ⊆ dgrad_p_set d m"
and ps_sub: "set ps ⊆ set bs × (set gs ∪ set bs)"
and "(set gs ∪ set bs) ∩ set hs = {}"
and uid: "unique_idx (gs @ bs @ hs) data" and gb: "is_Groebner_basis (fst ` set gs)"
and "h ≠ g" and "fst h ≠ 0" and "fst g ≠ 0"
assume *: "⋀a b. (a, b) ∈⇩p set (add_pairs gs bs ps hs data) ⟹
(a, b) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs) ⟹
fst a ≠ 0 ⟹ fst b ≠ 0 ⟹ crit_pair_cbelow_on d m (fst ` B) (fst a) (fst b)"
have "snd ` set ps1 ⊆ snd ` snd ` set (apply_icrit icrit data gs bs hs (np gs bs hs data))"
unfolding ps1_def by (rule apply_ncrit_subset')
also have "... = snd ` set (np gs bs hs data)" by simp
also from assms(1) have "... ⊆ set hs × (set gs ∪ set bs ∪ set hs)" by (rule np_specD1)
finally have ps1_sub: "snd ` set ps1 ⊆ set hs × (set gs ∪ set bs ∪ set hs)" .
from ‹(h, g) ∈ set ps› ps_sub have h_in: "h ∈ set gs ∪ set bs" and g_in: "g ∈ set gs ∪ set bs"
by fastforce+
with B_sup have "h ∈ B" and "g ∈ B" by auto
with assms(4) dg _ B_sub _ _ show "crit_pair_cbelow_on d m (fst ` B) (fst h) (fst g)"
using ‹fst h ≠ 0› ‹fst g ≠ 0› ‹(h, g) ∈ set ps›
proof (rule apply_ocrit_connectible)
from B_sup show "set hs ⊆ B" by simp
next
from ps1_sub h_in g_in
have "set (h # g # hs @ map (fst ∘ snd) ps1 @ map (snd ∘ snd) ps1) ⊆ set (gs @ bs @ hs)"
by fastforce
with uid show "unique_idx (h # g # hs @ map (fst ∘ snd) ps1 @ map (snd ∘ snd) ps1) data"
by (rule unique_idx_subset)
next
fix p q
assume "(p, q) ∈ snd ` set ps1"
hence pq_in: "(p, q) ∈ set hs × (set gs ∪ set bs ∪ set hs)" using ps1_sub ..
hence p_in: "p ∈ set hs" and q_in: "q ∈ set gs ∪ set bs ∪ set hs" by simp_all
assume "fst p ≠ 0" and "fst q ≠ 0"
from ‹(p, q) ∈ snd ` set ps1› obtain ic where "(ic, p, q) ∈ set ps1" by fastforce
show "crit_pair_cbelow_on d m (fst ` B) (fst p) (fst q)"
proof (cases "ic")
case True
hence "ic = True" by simp
from B_sup have B_sup': "fst ` (set gs ∪ set bs ∪ set hs) ⊆ fst ` B" by (rule image_mono)
note assms(2) dg
moreover from B_sup' B_sub have "fst ` (set gs ∪ set bs ∪ set hs) ⊆ dgrad_p_set d m"
by (rule subset_trans)
moreover note uid gb p_in q_in ‹fst p ≠ 0› ‹fst q ≠ 0›
moreover from ‹(ic, p, q) ∈ set ps1› obtain q_in_bs
where "(True, q_in_bs, p, q) ∈ set (apply_icrit icrit data gs bs hs (np gs bs hs data))"
unfolding ps1_def ‹ic = True› by (rule apply_ncrit_subset)
ultimately have "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs ∪ set hs)) (fst p) (fst q)"
by (rule fst_apply_icrit)
thus ?thesis using B_sup' by (rule crit_pair_cbelow_mono)
next
case False
with ‹(ic, p, q) ∈ set ps1› have "(False, p, q) ∈ set ps1" by simp
with assms(5) ps1_def have "(p, q) ∈ set (add_pairs gs bs ps hs data)"
by (simp add: set_add_pairs_iff)
hence "(p, q) ∈⇩p set (add_pairs gs bs ps hs data)" by (simp add: in_pair_iff)
moreover from pq_in have "(p, q) ∈⇩p set hs × (set gs ∪ set bs ∪ set hs)"
by (simp add: in_pair_iff)
ultimately show ?thesis using ‹fst p ≠ 0› ‹fst q ≠ 0› by (rule *)
qed
next
show "(h, g) ∉ set (apply_ocrit ocrit data hs ps1 ps)"
proof
assume "(h, g) ∈ set (apply_ocrit ocrit data hs ps1 ps)"
hence "(h, g) ∈ set (add_pairs gs bs ps hs data)"
by (simp add: add_pairs_def assms(5) Let_def ps1_def)
with ‹(h, g) ∉ set (add_pairs gs bs ps hs data)› show False ..
qed
qed
qed
end
abbreviation "add_pairs_canon ≡
add_pairs (new_pairs_sorted canon_pair_order) component_crit chain_ncrit chain_ocrit canon_pair_comb"
lemma ap_spec_add_pairs_canon: "ap_spec add_pairs_canon"
using np_spec_new_pairs_sorted icrit_spec_component_crit ncrit_spec_chain_ncrit
ocrit_spec_chain_ocrit set_merge_wrt
by (rule ap_spec_add_pairs)
subsection ‹Suitable Instances of the @{emph ‹completion›} Parameter›
definition rcp_spec :: "('t, 'b::field, 'c, 'd) complT ⇒ bool"
where "rcp_spec rcp ⟷
(∀gs bs ps sps data.
0 ∉ fst ` set (fst (rcp gs bs ps sps data)) ∧
(∀h b. h ∈ set (fst (rcp gs bs ps sps data)) ⟶ b ∈ set gs ∪ set bs ⟶ fst b ≠ 0 ⟶
¬ lt (fst b) adds⇩t lt (fst h)) ∧
(∀d. dickson_grading d ⟶
dgrad_p_set_le d (fst ` set (fst (rcp gs bs ps sps data))) (args_to_set (gs, bs, sps))) ∧
component_of_term ` Keys (fst ` (set (fst (rcp gs bs ps sps data)))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, sps)) ∧
(is_Groebner_basis (fst ` set gs) ⟶ unique_idx (gs @ bs) data ⟶
(fst ` set (fst (rcp gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps)) ∧
(∀(p, q)∈set sps. set sps ⊆ set bs × (set gs ∪ set bs) ⟶
(red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (rcp gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0))))"
text ‹Informally, ‹rcp_spec rcp› expresses that, for suitable ‹gs›, ‹bs› and ‹sps›, the value of
‹rcp gs bs ps sps›
\begin{itemize}
\item is a list consisting exclusively of non-zero polynomials contained in the module generated
by ‹set bs ∪ set gs›, whose leading terms are not divisible by the leading
term of any non-zero @{prop "b ∈ set bs"}, and
\item contains sufficiently many new polynomials such that all S-polynomials originating from
‹sps› can be reduced to ‹0› modulo the enlarged list of polynomials.
\end{itemize}›
lemma rcp_specI:
assumes "⋀gs bs ps sps data. 0 ∉ fst ` set (fst (rcp gs bs ps sps data))"
assumes "⋀gs bs ps sps h b data. h ∈ set (fst (rcp gs bs ps sps data)) ⟹ b ∈ set gs ∪ set bs ⟹ fst b ≠ 0 ⟹
¬ lt (fst b) adds⇩t lt (fst h)"
assumes "⋀gs bs ps sps d data. dickson_grading d ⟹
dgrad_p_set_le d (fst ` set (fst (rcp gs bs ps sps data))) (args_to_set (gs, bs, sps))"
assumes "⋀gs bs ps sps data. component_of_term ` Keys (fst ` (set (fst (rcp gs bs ps sps data)))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, sps))"
assumes "⋀gs bs ps sps data. is_Groebner_basis (fst ` set gs) ⟹ unique_idx (gs @ bs) data ⟹
(fst ` set (fst (rcp gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps)) ∧
(∀(p, q)∈set sps. set sps ⊆ set bs × (set gs ∪ set bs) ⟶
(red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (rcp gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0))"
shows "rcp_spec rcp"
unfolding rcp_spec_def using assms by auto
lemma rcp_specD1:
assumes "rcp_spec rcp"
shows "0 ∉ fst ` set (fst (rcp gs bs ps sps data))"
using assms unfolding rcp_spec_def by (elim allE conjE)
lemma rcp_specD2:
assumes "rcp_spec rcp"
and "h ∈ set (fst (rcp gs bs ps sps data))" and "b ∈ set gs ∪ set bs" and "fst b ≠ 0"
shows "¬ lt (fst b) adds⇩t lt (fst h)"
using assms unfolding rcp_spec_def by (elim allE conjE, blast)
lemma rcp_specD3:
assumes "rcp_spec rcp" and "dickson_grading d"
shows "dgrad_p_set_le d (fst ` set (fst (rcp gs bs ps sps data))) (args_to_set (gs, bs, sps))"
using assms unfolding rcp_spec_def by (elim allE conjE, blast)
lemma rcp_specD4:
assumes "rcp_spec rcp"
shows "component_of_term ` Keys (fst ` (set (fst (rcp gs bs ps sps data)))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, sps))"
using assms unfolding rcp_spec_def by (elim allE conjE)
lemma rcp_specD5:
assumes "rcp_spec rcp" and "is_Groebner_basis (fst ` set gs)" and "unique_idx (gs @ bs) data"
shows "fst ` set (fst (rcp gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps))"
using assms unfolding rcp_spec_def by blast
lemma rcp_specD6:
assumes "rcp_spec rcp" and "is_Groebner_basis (fst ` set gs)" and "unique_idx (gs @ bs) data"
and "set sps ⊆ set bs × (set gs ∪ set bs)"
and "(p, q) ∈ set sps"
shows "(red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (rcp gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0"
using assms unfolding rcp_spec_def by blast
lemma compl_struct_rcp:
assumes "rcp_spec rcp"
shows "compl_struct rcp"
proof (rule compl_structI)
fix d::"'a ⇒ nat" and gs bs ps and sps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd"
assume "dickson_grading d" and "set sps ⊆ set ps"
from assms this(1) have "dgrad_p_set_le d (fst ` set (fst (rcp gs bs (ps -- sps) sps data)))
(args_to_set (gs, bs, sps))"
by (rule rcp_specD3)
also have "dgrad_p_set_le d ... (args_to_set (gs, bs, ps))"
by (rule dgrad_p_set_le_subset, rule args_to_set_subset3, fact ‹set sps ⊆ set ps›)
finally show "dgrad_p_set_le d (fst ` set (fst (rcp gs bs (ps -- sps) sps data)))
(args_to_set (gs, bs, ps))" .
next
fix gs bs ps and sps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd"
from assms show "0 ∉ fst ` set (fst (rcp gs bs (ps -- sps) sps data))"
by (rule rcp_specD1)
next
fix gs bs ps sps h b data
assume "h ∈ set (fst (rcp gs bs (ps -- sps) sps data))"
and "b ∈ set gs ∪ set bs" and "fst b ≠ 0"
with assms show "¬ lt (fst b) adds⇩t lt (fst h)" by (rule rcp_specD2)
next
fix gs bs ps and sps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd"
assume "set sps ⊆ set ps"
from assms
have "component_of_term ` Keys (fst ` set (fst (rcp gs bs (ps -- sps) sps data))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, sps))"
by (rule rcp_specD4)
also have "... ⊆ component_of_term ` Keys (args_to_set (gs, bs, ps))"
by (rule image_mono, rule Keys_mono, rule args_to_set_subset3, fact ‹set sps ⊆ set ps›)
finally show "component_of_term ` Keys (fst ` set (fst (rcp gs bs (ps -- sps) sps data))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, ps))" .
qed
lemma compl_pmdl_rcp:
assumes "rcp_spec rcp"
shows "compl_pmdl rcp"
proof (rule compl_pmdlI)
fix gs bs :: "('t, 'b, 'c) pdata list" and ps sps :: "('t, 'b, 'c) pdata_pair list" and data::"nat × 'd"
assume gb: "is_Groebner_basis (fst ` set gs)" and "set sps ⊆ set ps"
and un: "unique_idx (gs @ bs) data"
let ?res = "fst (rcp gs bs (ps -- sps) sps data)"
from assms gb un have "fst ` set ?res ⊆ pmdl (args_to_set (gs, bs, sps))"
by (rule rcp_specD5)
also have "... ⊆ pmdl (args_to_set (gs, bs, ps))"
by (rule pmdl.span_mono, rule args_to_set_subset3, fact ‹set sps ⊆ set ps›)
finally show "fst ` set ?res ⊆ pmdl (args_to_set (gs, bs, ps))" .
qed
lemma compl_conn_rcp:
assumes "rcp_spec rcp"
shows "compl_conn rcp"
proof (rule compl_connI)
fix d::"'a ⇒ nat" and m gs bs ps sps p and q::"('t, 'b, 'c) pdata" and data::"nat × 'd"
assume dg: "dickson_grading d" and gs_sub: "fst ` set gs ⊆ dgrad_p_set d m"
and gb: "is_Groebner_basis (fst ` set gs)" and bs_sub: "fst ` set bs ⊆ dgrad_p_set d m"
and ps_sub: "set ps ⊆ set bs × (set gs ∪ set bs)" and "set sps ⊆ set ps"
and uid: "unique_idx (gs @ bs) data"
and "(p, q) ∈ set sps" and "fst p ≠ 0" and "fst q ≠ 0"
from ‹set sps ⊆ set ps› ps_sub have sps_sub: "set sps ⊆ set bs × (set gs ∪ set bs)"
by (rule subset_trans)
let ?res = "fst (rcp gs bs (ps -- sps) sps data)"
have "fst ` set ?res ⊆ dgrad_p_set d m"
proof (rule dgrad_p_set_le_dgrad_p_set, rule rcp_specD3, fact+)
show "args_to_set (gs, bs, sps) ⊆ dgrad_p_set d m"
by (simp add: args_to_set_subset_Times[OF sps_sub], rule, fact+)
qed
moreover have gs_bs_sub: "fst ` (set gs ∪ set bs) ⊆ dgrad_p_set d m" by (simp add: image_Un, rule, fact+)
ultimately have res_sub: "fst ` (set gs ∪ set bs) ∪ fst ` set ?res ⊆ dgrad_p_set d m" by simp
from ‹(p, q) ∈ set sps› ‹set sps ⊆ set ps› ps_sub
have "fst p ∈ fst ` set bs" and "fst q ∈ fst ` (set gs ∪ set bs)" by auto
with ‹fst ` set bs ⊆ dgrad_p_set d m› gs_bs_sub
have "fst p ∈ dgrad_p_set d m" and "fst q ∈ dgrad_p_set d m" by auto
with dg res_sub show "crit_pair_cbelow_on d m (fst ` (set gs ∪ set bs) ∪ fst ` set ?res) (fst p) (fst q)"
using ‹fst p ≠ 0› ‹fst q ≠ 0›
proof (rule spoly_red_zero_imp_crit_pair_cbelow_on)
from assms gb uid sps_sub ‹(p, q) ∈ set sps›
show "(red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (rcp gs bs (ps -- sps) sps data))))⇧*⇧*
(spoly (fst p) (fst q)) 0"
by (rule rcp_specD6)
qed
qed
end
subsection ‹Suitable Instances of the @{emph ‹add-basis›} Parameter›
definition add_basis_naive :: "('a, 'b, 'c, 'd) abT"
where "add_basis_naive gs bs ns data = bs @ ns"
lemma ab_spec_add_basis_naive: "ab_spec add_basis_naive"
by (rule ab_specI, simp_all add: add_basis_naive_def)
definition add_basis_sorted :: "(nat × 'd ⇒ ('a, 'b, 'c) pdata ⇒ ('a, 'b, 'c) pdata ⇒ bool) ⇒ ('a, 'b, 'c, 'd) abT"
where "add_basis_sorted rel gs bs ns data = merge_wrt (rel data) bs ns"
lemma ab_spec_add_basis_sorted: "ab_spec (add_basis_sorted rel)"
by (rule ab_specI, simp_all add: add_basis_sorted_def set_merge_wrt)
definition card_keys :: "('a ⇒⇩0 'b::zero) ⇒ nat"
where "card_keys = card ∘ keys"
definition (in ordered_term) canon_basis_order :: "'d ⇒ ('t, 'b::zero, 'c) pdata ⇒ ('t, 'b, 'c) pdata ⇒ bool"
where "canon_basis_order data p q ⟷
(let cp = card_keys (fst p); cq = card_keys (fst q) in
cp < cq ∨ (cp = cq ∧ lt (fst p) ≺⇩t lt (fst q)))"
abbreviation (in ordered_term) "add_basis_canon ≡ add_basis_sorted canon_basis_order"
subsection ‹Special Case: Scalar Polynomials›
context gd_powerprod
begin
lemma remdups_map_component_of_term_punit:
"remdups (map (λ_. ()) (punit.Keys_to_list (map fst bs))) =
(if (∀b∈set bs. fst b = 0) then [] else [()])"
proof (split if_split, intro conjI impI)
assume "∀b∈set bs. fst b = 0"
hence "fst ` set bs ⊆ {0}" by blast
hence "Keys (fst ` set bs) = {}" by (metis Keys_empty Keys_zero subset_singleton_iff)
hence "punit.Keys_to_list (map fst bs) = []"
by (simp add: set_empty[symmetric] punit.set_Keys_to_list del: set_empty)
thus "remdups (map (λ_. ()) (punit.Keys_to_list (map fst bs))) = []" by simp
next
assume "¬ (∀b∈set bs. fst b = 0)"
hence "∃b∈set bs. fst b ≠ 0" by simp
then obtain b where "b ∈ set bs" and "fst b ≠ 0" ..
hence "Keys (fst ` set bs) ≠ {}" by (meson Keys_not_empty ‹fst b ≠ 0› imageI)
hence "set (punit.Keys_to_list (map fst bs)) ≠ {}" by (simp add: punit.set_Keys_to_list)
hence "punit.Keys_to_list (map fst bs) ≠ []" by simp
thus "remdups (map (λ_. ()) (punit.Keys_to_list (map fst bs))) = [()]"
by (metis (full_types) old.unit.exhaust sorted.cases Nil_is_map_conv ‹punit.Keys_to_list (map fst bs) ≠ []› distinct_length_2_or_more distinct_remdups remdups_eq_nil_right_iff)
qed
lemma count_const_lt_components_punit [code]:
"punit.count_const_lt_components hs =
(if (∃h∈set hs. punit.const_lt_component (fst h) = Some ()) then 1 else 0)"
proof (simp add: punit.count_const_lt_components_def cong del: image_cong_simp,
simp add: card_set [symmetric] cong del: image_cong_simp, rule)
assume "∃h∈set hs. punit.const_lt_component (fst h) = Some ()"
then obtain h where "h ∈ set hs" and "punit.const_lt_component (fst h) = Some ()" ..
from this(2) have "(punit.const_lt_component ∘ fst) h = Some ()" by simp
with ‹h ∈ set hs› have "Some () ∈ (punit.const_lt_component ∘ fst) ` set hs"
by (metis rev_image_eqI)
hence "{x. x = Some () ∧ x ∈ (punit.const_lt_component ∘ fst) ` set hs} = {Some ()}" by auto
thus "card {x. x = Some () ∧ x ∈ (punit.const_lt_component ∘ fst) ` set hs} = Suc 0" by simp
qed
lemma count_rem_components_punit [code]:
"punit.count_rem_components bs =
(if (∀b∈set bs. fst b = 0) then 0
else
if (∃b∈set bs. fst b ≠ 0 ∧ punit.const_lt_component (fst b) = Some ()) then 0 else 1)"
proof (cases "∀b∈set bs. fst b = 0")
case True
thus ?thesis by (simp add: punit.count_rem_components_def remdups_map_component_of_term_punit)
next
case False
have eq: "(∃b∈set [b←bs . fst b ≠ 0]. punit.const_lt_component (fst b) = Some ()) =
(∃b∈set bs. fst b ≠ 0 ∧ punit.const_lt_component (fst b) = Some ())"
by (metis (mono_tags, lifting) filter_set member_filter)
show ?thesis
by (simp only: False punit.count_rem_components_def eq if_False
remdups_map_component_of_term_punit count_const_lt_components_punit punit_component_of_term, simp)
qed
lemma full_gb_punit [code]:
"punit.full_gb bs = (if (∀b∈set bs. fst b = 0) then [] else [(1, 0, default)])"
by (simp add: punit.full_gb_def remdups_map_component_of_term_punit)
abbreviation "add_pairs_punit_canon ≡
punit.add_pairs (punit.new_pairs_sorted punit.canon_pair_order) punit.product_crit punit.chain_ncrit
punit.chain_ocrit punit.canon_pair_comb"
lemma ap_spec_add_pairs_punit_canon: "punit.ap_spec add_pairs_punit_canon"
using punit.np_spec_new_pairs_sorted punit.icrit_spec_product_crit punit.ncrit_spec_chain_ncrit
punit.ocrit_spec_chain_ocrit set_merge_wrt
by (rule punit.ap_spec_add_pairs)
end
end
Theory Buchberger
section ‹Buchberger's Algorithm›
theory Buchberger
imports Algorithm_Schema
begin
context gd_term
begin
subsection ‹Reduction›
definition trdsp::"('t ⇒⇩0 'b) list ⇒ ('t, 'b, 'c) pdata_pair ⇒ ('t ⇒⇩0 'b::field)"
where "trdsp bs p ≡ trd bs (spoly (fst (fst p)) (fst (snd p)))"
lemma trdsp_alt: "trdsp bs (p, q) = trd bs (spoly (fst p) (fst q))"
by (simp add: trdsp_def)
lemma trdsp_in_pmdl: "trdsp bs (p, q) ∈ pmdl (insert (fst p) (insert (fst q) (set bs)))"
unfolding trdsp_alt
proof (rule pmdl_closed_trd)
have "spoly (fst p) (fst q) ∈ pmdl {fst p, fst q}"
proof (rule pmdl_closed_spoly)
show "fst p ∈ pmdl {fst p, fst q}" by (rule pmdl.span_base, simp)
next
show "fst q ∈ pmdl {fst p, fst q}" by (rule pmdl.span_base, simp)
qed
also have "... ⊆ pmdl (insert (fst p) (insert (fst q) (set bs)))"
by (rule pmdl.span_mono, simp)
finally show "spoly (fst p) (fst q) ∈ pmdl (insert (fst p) (insert (fst q) (set bs)))" .
next
have "set bs ⊆ insert (fst p) (insert (fst q) (set bs))" by blast
also have "... ⊆ pmdl (insert (fst p) (insert (fst q) (set bs)))"
by (fact pmdl.span_superset)
finally show "set bs ⊆ pmdl (insert (fst p) (insert (fst q) (set bs)))" .
qed
lemma dgrad_p_set_le_trdsp:
assumes "dickson_grading d"
shows "dgrad_p_set_le d {trdsp bs (p, q)} (insert (fst p) (insert (fst q) (set bs)))"
proof -
let ?h = "trdsp bs (p, q)"
have "(red (set bs))⇧*⇧* (spoly (fst p) (fst q)) ?h" unfolding trdsp_alt by (rule trd_red_rtrancl)
with assms have "dgrad_p_set_le d {?h} (insert (spoly (fst p) (fst q)) (set bs))"
by (rule dgrad_p_set_le_red_rtrancl)
also have "dgrad_p_set_le d ... ({fst p, fst q} ∪ set bs)"
proof (rule dgrad_p_set_leI_insert)
show "dgrad_p_set_le d (set bs) ({fst p, fst q} ∪ set bs)" by (rule dgrad_p_set_le_subset, blast)
next
from assms have "dgrad_p_set_le d {spoly (fst p) (fst q)} {fst p, fst q}"
by (rule dgrad_p_set_le_spoly)
also have "dgrad_p_set_le d ... ({fst p, fst q} ∪ set bs)"
by (rule dgrad_p_set_le_subset, blast)
finally show "dgrad_p_set_le d {spoly (fst p) (fst q)} ({fst p, fst q} ∪ set bs)" .
qed
finally show ?thesis by simp
qed
lemma components_trdsp_subset:
"component_of_term ` keys (trdsp bs (p, q)) ⊆ component_of_term ` Keys (insert (fst p) (insert (fst q) (set bs)))"
proof -
let ?h = "trdsp bs (p, q)"
have "(red (set bs))⇧*⇧* (spoly (fst p) (fst q)) ?h" unfolding trdsp_alt by (rule trd_red_rtrancl)
hence "component_of_term ` keys ?h ⊆
component_of_term ` keys (spoly (fst p) (fst q)) ∪ component_of_term ` Keys (set bs)"
by (rule components_red_rtrancl_subset)
also have "... ⊆ component_of_term ` Keys {fst p, fst q} ∪ component_of_term ` Keys (set bs)"
using components_spoly_subset by force
also have "... = component_of_term ` Keys (insert (fst p) (insert (fst q) (set bs)))"
by (simp add: Keys_insert image_Un Un_assoc)
finally show ?thesis .
qed
definition gb_red_aux :: "('t, 'b::field, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒
('t ⇒⇩0 'b) list"
where "gb_red_aux bs ps =
(let bs' = map fst bs in
filter (λh. h ≠ 0) (map (trdsp bs') ps)
)"
text ‹Actually, @{const gb_red_aux} is only called on singleton lists.›
lemma set_gb_red_aux: "set (gb_red_aux bs ps) = (trdsp (map fst bs)) ` set ps - {0}"
by (simp add: gb_red_aux_def, blast)
lemma in_set_gb_red_auxI:
assumes "(p, q) ∈ set ps" and "h = trdsp (map fst bs) (p, q)" and "h ≠ 0"
shows "h ∈ set (gb_red_aux bs ps)"
using assms(1, 3) unfolding set_gb_red_aux assms(2) by force
lemma in_set_gb_red_auxE:
assumes "h ∈ set (gb_red_aux bs ps)"
obtains p q where "(p, q) ∈ set ps" and "h = trdsp (map fst bs) (p, q)"
using assms unfolding set_gb_red_aux by force
lemma gb_red_aux_not_zero: "0 ∉ set (gb_red_aux bs ps)"
by (simp add: set_gb_red_aux)
lemma gb_red_aux_irredudible:
assumes "h ∈ set (gb_red_aux bs ps)" and "b ∈ set bs" and "fst b ≠ 0"
shows "¬ lt (fst b) adds⇩t lt h"
proof
assume "lt (fst b) adds⇩t (lt h)"
from assms(1) obtain p q :: "('t, 'b, 'c) pdata" where h: "h = trdsp (map fst bs) (p, q)"
by (rule in_set_gb_red_auxE)
have "¬ is_red (set (map fst bs)) h" unfolding h trdsp_def by (rule trd_irred)
moreover have "is_red (set (map fst bs)) h"
proof (rule is_red_addsI)
from assms(2) show "fst b ∈ set (map fst bs)" by (simp)
next
from assms(1) have "h ≠ 0" by (simp add: set_gb_red_aux)
thus "lt h ∈ keys h" by (rule lt_in_keys)
qed fact+
ultimately show False ..
qed
lemma gb_red_aux_dgrad_p_set_le:
assumes "dickson_grading d"
shows "dgrad_p_set_le d (set (gb_red_aux bs ps)) (args_to_set ([], bs, ps))"
proof (rule dgrad_p_set_leI)
fix h
assume "h ∈ set (gb_red_aux bs ps)"
then obtain p q where "(p, q) ∈ set ps" and h: "h = trdsp (map fst bs) (p, q)"
by (rule in_set_gb_red_auxE)
from assms have "dgrad_p_set_le d {h} (insert (fst p) (insert (fst q) (set (map fst bs))))"
unfolding h by (rule dgrad_p_set_le_trdsp)
also have "dgrad_p_set_le d ... (args_to_set ([], bs, ps))"
proof (rule dgrad_p_set_le_subset, intro insert_subsetI)
from ‹(p, q) ∈ set ps› have "fst p ∈ fst ` fst ` set ps" by force
thus "fst p ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
next
from ‹(p, q) ∈ set ps› have "fst q ∈ fst ` snd ` set ps" by force
thus "fst q ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
next
show "set (map fst bs) ⊆ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
qed
finally show "dgrad_p_set_le d {h} (args_to_set ([], bs, ps))" .
qed
lemma components_gb_red_aux_subset:
"component_of_term ` Keys (set (gb_red_aux bs ps)) ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))"
proof
fix k
assume "k ∈ component_of_term ` Keys (set (gb_red_aux bs ps))"
then obtain v where "v ∈ Keys (set (gb_red_aux bs ps))" and k: "k = component_of_term v" ..
from this(1) obtain h where "h ∈ set (gb_red_aux bs ps)" and "v ∈ keys h" by (rule in_KeysE)
from this(1) obtain p q where "(p, q) ∈ set ps" and h: "h = trdsp (map fst bs) (p, q)"
by (rule in_set_gb_red_auxE)
from ‹v ∈ keys h› have "k ∈ component_of_term ` keys h" by (simp add: k)
have "component_of_term ` keys h ⊆ component_of_term ` Keys (insert (fst p) (insert (fst q) (set (map fst bs))))"
unfolding h by (rule components_trdsp_subset)
also have "... ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))"
proof (rule image_mono, rule Keys_mono, intro insert_subsetI)
from ‹(p, q) ∈ set ps› have "fst p ∈ fst ` fst ` set ps" by force
thus "fst p ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
next
from ‹(p, q) ∈ set ps› have "fst q ∈ fst ` snd ` set ps" by force
thus "fst q ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
next
show "set (map fst bs) ⊆ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
qed
finally have "component_of_term ` keys h ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))" .
with ‹k ∈ component_of_term ` keys h› show "k ∈ component_of_term ` Keys (args_to_set ([], bs, ps))" ..
qed
lemma pmdl_gb_red_aux: "set (gb_red_aux bs ps) ⊆ pmdl (args_to_set ([], bs, ps))"
proof
fix h
assume "h ∈ set (gb_red_aux bs ps)"
then obtain p q where "(p, q) ∈ set ps" and h: "h = trdsp (map fst bs) (p, q)"
by (rule in_set_gb_red_auxE)
have "h ∈ pmdl (insert (fst p) (insert (fst q) (set (map fst bs))))" unfolding h
by (fact trdsp_in_pmdl)
also have "... ⊆ pmdl (args_to_set ([], bs, ps))"
proof (rule pmdl.span_mono, intro insert_subsetI)
from ‹(p, q) ∈ set ps› have "fst p ∈ fst ` fst ` set ps" by force
thus "fst p ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
next
from ‹(p, q) ∈ set ps› have "fst q ∈ fst ` snd ` set ps" by force
thus "fst q ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
next
show "set (map fst bs) ⊆ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
qed
finally show "h ∈ pmdl (args_to_set ([], bs, ps))" .
qed
lemma gb_red_aux_spoly_reducible:
assumes "(p, q) ∈ set ps"
shows "(red (fst ` set bs ∪ set (gb_red_aux bs ps)))⇧*⇧* (spoly (fst p) (fst q)) 0"
proof -
define h where "h = trdsp (map fst bs) (p, q)"
from trd_red_rtrancl[of "map fst bs" "spoly (fst p) (fst q)"]
have "(red (set (map fst bs)))⇧*⇧* (spoly (fst p) (fst q)) h"
by (simp only: h_def trdsp_alt)
hence "(red (fst ` set bs ∪ set (gb_red_aux bs ps)))⇧*⇧* (spoly (fst p) (fst q)) h"
proof (rule red_rtrancl_subset)
show "set (map fst bs) ⊆ fst ` set bs ∪ set (gb_red_aux bs ps)" by simp
qed
moreover have "(red (fst ` set bs ∪ set (gb_red_aux bs ps)))⇧*⇧* h 0"
proof (cases "h = 0")
case True
show ?thesis unfolding True ..
next
case False
hence "red {h} h 0" by (rule red_self)
hence "red (fst ` set bs ∪ set (gb_red_aux bs ps)) h 0"
proof (rule red_subset)
from assms h_def False have "h ∈ set (gb_red_aux bs ps)" by (rule in_set_gb_red_auxI)
thus "{h} ⊆ fst ` set bs ∪ set (gb_red_aux bs ps)" by simp
qed
thus ?thesis ..
qed
ultimately show ?thesis by simp
qed
definition gb_red :: "('t, 'b::field, 'c::default, 'd) complT"
where "gb_red gs bs ps sps data = (map (λh. (h, default)) (gb_red_aux (gs @ bs) sps), snd data)"
lemma fst_set_fst_gb_red: "fst ` set (fst (gb_red gs bs ps sps data)) = set (gb_red_aux (gs @ bs) sps)"
by (simp add: gb_red_def, force)
lemma rcp_spec_gb_red: "rcp_spec gb_red"
proof (rule rcp_specI)
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd"
from gb_red_aux_not_zero show "0 ∉ fst ` set (fst (gb_red gs bs ps sps data))"
unfolding fst_set_fst_gb_red .
next
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps h b and data::"nat × 'd"
assume "h ∈ set (fst (gb_red gs bs ps sps data))" and "b ∈ set gs ∪ set bs"
from this(1) have "fst h ∈ fst ` set (fst (gb_red gs bs ps sps data))" by simp
hence "fst h ∈ set (gb_red_aux (gs @ bs) sps)" by (simp only: fst_set_fst_gb_red)
moreover from ‹b ∈ set gs ∪ set bs› have "b ∈ set (gs @ bs)" by simp
moreover assume "fst b ≠ 0"
ultimately show "¬ lt (fst b) adds⇩t lt (fst h)" by (rule gb_red_aux_irredudible)
next
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and d::"'a ⇒ nat" and data::"nat × 'd"
assume "dickson_grading d"
hence "dgrad_p_set_le d (set (gb_red_aux (gs @ bs) sps)) (args_to_set ([], gs @ bs, sps))"
by (rule gb_red_aux_dgrad_p_set_le)
also have "... = args_to_set (gs, bs, sps)" by (simp add: args_to_set_alt image_Un)
finally show "dgrad_p_set_le d (fst ` set (fst (gb_red gs bs ps sps data))) (args_to_set (gs, bs, sps))"
by (simp only: fst_set_fst_gb_red)
next
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd"
have "component_of_term ` Keys (set (gb_red_aux (gs @ bs) sps)) ⊆
component_of_term ` Keys (args_to_set ([], gs @ bs, sps))"
by (rule components_gb_red_aux_subset)
also have "... = component_of_term ` Keys (args_to_set (gs, bs, sps))"
by (simp add: args_to_set_alt image_Un)
finally show "component_of_term ` Keys (fst ` set (fst (gb_red gs bs ps sps data))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, sps))" by (simp only: fst_set_fst_gb_red)
next
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd"
have "set (gb_red_aux (gs @ bs) sps) ⊆ pmdl (args_to_set ([], gs @ bs, sps))"
by (fact pmdl_gb_red_aux)
also have "... = pmdl (args_to_set (gs, bs, sps))" by (simp add: args_to_set_alt image_Un)
finally have "fst ` set (fst (gb_red gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps))"
by (simp only: fst_set_fst_gb_red)
moreover {
fix p q :: "('t, 'b, 'c) pdata"
assume "(p, q) ∈ set sps"
hence "(red (fst ` set (gs @ bs) ∪ set (gb_red_aux (gs @ bs) sps)))⇧*⇧* (spoly (fst p) (fst q)) 0"
by (rule gb_red_aux_spoly_reducible)
}
ultimately show
"fst ` set (fst (gb_red gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps)) ∧
(∀(p, q)∈set sps.
set sps ⊆ set bs × (set gs ∪ set bs) ⟶
(red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (gb_red gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0)"
by (auto simp add: image_Un fst_set_fst_gb_red)
qed
lemmas compl_struct_gb_red = compl_struct_rcp[OF rcp_spec_gb_red]
lemmas compl_pmdl_gb_red = compl_pmdl_rcp[OF rcp_spec_gb_red]
lemmas compl_conn_gb_red = compl_conn_rcp[OF rcp_spec_gb_red]
subsection ‹Pair Selection›
primrec gb_sel :: "('t, 'b::zero, 'c, 'd) selT" where
"gb_sel gs bs [] data = []"|
"gb_sel gs bs (p # ps) data = [p]"
lemma sel_spec_gb_sel: "sel_spec gb_sel"
proof (rule sel_specI)
fix gs bs :: "('t, 'b, 'c) pdata list" and ps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd"
assume "ps ≠ []"
then obtain p ps' where ps: "ps = p # ps'" by (meson list.exhaust)
show "gb_sel gs bs ps data ≠ [] ∧ set (gb_sel gs bs ps data) ⊆ set ps" by (simp add: ps)
qed
subsection ‹Buchberger's Algorithm›
lemma struct_spec_gb: "struct_spec gb_sel add_pairs_canon add_basis_canon gb_red"
using sel_spec_gb_sel ap_spec_add_pairs_canon ab_spec_add_basis_sorted compl_struct_gb_red
by (rule struct_specI)
definition gb_aux :: "('t, 'b, 'c) pdata list ⇒ nat × nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b::field, 'c::default) pdata list"
where "gb_aux = gb_schema_aux gb_sel add_pairs_canon add_basis_canon gb_red"
lemmas gb_aux_simps [code] = gb_schema_aux_simps[OF struct_spec_gb, folded gb_aux_def]
definition gb :: "('t, 'b, 'c) pdata' list ⇒ 'd ⇒ ('t, 'b::field, 'c::default) pdata' list"
where "gb = gb_schema_direct gb_sel add_pairs_canon add_basis_canon gb_red"
lemmas gb_simps [code] = gb_schema_direct_def[of gb_sel add_pairs_canon add_basis_canon gb_red, folded gb_def gb_aux_def]
lemmas gb_isGB = gb_schema_direct_isGB[OF struct_spec_gb compl_conn_gb_red, folded gb_def]
lemmas gb_pmdl = gb_schema_direct_pmdl[OF struct_spec_gb compl_pmdl_gb_red, folded gb_def]
subsubsection ‹Special Case: ‹punit››
lemma (in gd_term) struct_spec_gb_punit: "punit.struct_spec punit.gb_sel add_pairs_punit_canon punit.add_basis_canon punit.gb_red"
using punit.sel_spec_gb_sel ap_spec_add_pairs_punit_canon ab_spec_add_basis_sorted punit.compl_struct_gb_red
by (rule punit.struct_specI)
definition gb_aux_punit :: "('a, 'b, 'c) pdata list ⇒ nat × nat × 'd ⇒ ('a, 'b, 'c) pdata list ⇒
('a, 'b, 'c) pdata_pair list ⇒ ('a, 'b::field, 'c::default) pdata list"
where "gb_aux_punit = punit.gb_schema_aux punit.gb_sel add_pairs_punit_canon punit.add_basis_canon punit.gb_red"
lemmas gb_aux_punit_simps [code] = punit.gb_schema_aux_simps[OF struct_spec_gb_punit, folded gb_aux_punit_def]
definition gb_punit :: "('a, 'b, 'c) pdata' list ⇒ 'd ⇒ ('a, 'b::field, 'c::default) pdata' list"
where "gb_punit = punit.gb_schema_direct punit.gb_sel add_pairs_punit_canon punit.add_basis_canon punit.gb_red"
lemmas gb_punit_simps [code] = punit.gb_schema_direct_def[of "punit.gb_sel" add_pairs_punit_canon
"punit.add_basis_canon" "punit.gb_red", folded gb_punit_def gb_aux_punit_def]
lemmas gb_punit_isGB = punit.gb_schema_direct_isGB[OF struct_spec_gb_punit punit.compl_conn_gb_red, folded gb_punit_def]
lemmas gb_punit_pmdl = punit.gb_schema_direct_pmdl[OF struct_spec_gb_punit punit.compl_pmdl_gb_red, folded gb_punit_def]
end
end
Theory Benchmarks
section ‹Benchmark Problems for Computing Gr\"obner Bases›
theory Benchmarks
imports Polynomials.MPoly_Type_Class_OAlist
begin
text ‹This theory defines various well-known benchmark problems for computing Gr\"obner bases. The
actual tests of the different algorithms on these problems are contained in the theories whose
names end with ‹_Examples›.›
subsection ‹Cyclic›
definition cycl_pp :: "nat ⇒ nat ⇒ nat ⇒ (nat, nat) pp"
where "cycl_pp n d i = sparse⇩0 (map (λk. (modulo (k + i) n, 1)) [0..<d])"
definition cyclic :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::{zero,one,uminus}) list"
where "cyclic to n =
(let xs = [0..<n] in
(map (λd. distr⇩0 to (map (λi. (cycl_pp n d i, 1)) xs)) [1..<n]) @
[distr⇩0 to [(cycl_pp n n 0, 1), (0, -1)]]
)"
text ‹@{term "cyclic n"} is a system of ‹n› polynomials in ‹n› indeterminates, with maximum degree ‹n›.›
subsection ‹Katsura›
definition katsura_poly :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1)"
where "katsura_poly to n i =
change_ord to ((∑j::int=-int n..<n + 1. if abs (i - j) ≤ n then V⇩0 (nat (abs j)) * V⇩0 (nat (abs (i - j))) else 0) - V⇩0 i)"
definition katsura :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1) list"
where "katsura to n =
(let xs = [0..<n] in
(distr⇩0 to ((sparse⇩0 [(0, 1)], 1) # (map (λi. (sparse⇩0 [(Suc i, 1)], 2)) xs) @ [(0, -1)])) #
(map (katsura_poly to n) xs)
)"
text ‹For @{prop "1 ≤ n"}, @{term "katsura n"} is a system of ‹n + 1› polynomials in ‹n + 1›
indeterminates, with maximum degree ‹2›.›
subsection ‹Eco›
definition eco_poly :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1)"
where "eco_poly to m i =
distr⇩0 to ((sparse⇩0 [(i, 1), (m, 1)], 1) # map (λj. (sparse⇩0 [(j, 1), (j + i + 1, 1), (m, 1)], 1)) [0..<m - i - 1])"
definition eco :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1) list"
where "eco to n =
(let m = n - 1 in
(distr⇩0 to ((map (λj. (sparse⇩0 [(j, 1)], 1)) [0..<m]) @ [(0, 1)])) #
(distr⇩0 to [(sparse⇩0 [(m-1, 1), (m,1)], 1), (0, - of_nat m)]) #
(rev (map (eco_poly to m) [0..<m-1]))
)"
text ‹For @{prop "2 ≤ n"}, @{term "eco n"} is a system of ‹n› polynomials in ‹n› indeterminates,
with maximum degree ‹3›.›
subsection ‹Noon›
definition noon_poly :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1)"
where "noon_poly to n i =
(let ten = of_nat 10; eleven = - of_nat 11 in
distr⇩0 to ((map (λj. if j = i then (sparse⇩0 [(i, 1)], eleven) else (sparse⇩0 [(j, 2), (i, 1)], ten)) [0..<n]) @
[(0, ten)]))"
definition noon :: "(nat, nat) pp nat_term_order ⇒ nat ⇒ ((nat, nat) pp ⇒⇩0 'a::comm_ring_1) list"
where "noon to n = (noon_poly to n 1) # (noon_poly to n 0) # (map (noon_poly to n) [2..<n])"
text ‹For @{prop "2 ≤ n"}, @{term "noon n"} is a system of ‹n› polynomials in ‹n› indeterminates,
with maximum degree ‹3›.›
end
Theory Algorithm_Schema_Impl
section ‹Code Equations Related to the Computation of Gr\"obner Bases›
theory Algorithm_Schema_Impl
imports Algorithm_Schema Benchmarks
begin
lemma card_keys_MP_oalist [code]: "card_keys (MP_oalist xs) = length (fst (list_of_oalist_ntm xs))"
proof -
let ?rel = "ko.lt (key_order_of_nat_term_order_inv (snd (list_of_oalist_ntm xs)))"
have "irreflp ?rel" by (simp add: irreflp_def)
moreover have "transp ?rel" by (simp add: lt_of_nat_term_order_alt)
ultimately have *: "distinct (map fst (fst (list_of_oalist_ntm xs)))" using oa_ntm.list_of_oalist_sorted
by (rule distinct_sorted_wrt_irrefl)
have "card_keys (MP_oalist xs) = length (map fst (fst (list_of_oalist_ntm xs)))"
by (simp only: card_keys_def keys_MP_oalist image_set o_def oa_ntm.sorted_domain_def[symmetric],
rule distinct_card, fact *)
also have "... = length (fst (list_of_oalist_ntm xs))" by simp
finally show ?thesis .
qed
end
Theory Code_Target_Rat
theory Code_Target_Rat
imports Complex_Main "HOL-Library.Code_Target_Numeral"
begin
text ‹Mapping type @{typ rat} to type "Rat.rat" in Isabelle/ML. Serialization for other target
languages will be provided in the future.›
context includes integer.lifting begin
lift_definition rat_of_integer :: "integer ⇒ rat" is Rat.of_int .
lift_definition quotient_of' :: "rat ⇒ integer × integer" is quotient_of .
lemma [code]: "Rat.of_int (int_of_integer x) = rat_of_integer x"
by transfer simp
lemma [code_unfold]: "quotient_of = (λx. map_prod int_of_integer int_of_integer (quotient_of' x))"
by transfer simp
end
code_printing
type_constructor rat ⇀
(SML) "Rat.rat" |
constant "plus :: rat ⇒ _ ⇒ _" ⇀
(SML) "Rat.add" |
constant "minus :: rat ⇒ _ ⇒ _" ⇀
(SML) "Rat.add ((_)) (Rat.neg ((_)))" |
constant "times :: rat ⇒ _ ⇒ _" ⇀
(SML) "Rat.mult" |
constant "inverse :: rat ⇒ _" ⇀
(SML) "Rat.inv" |
constant "divide :: rat ⇒ _ ⇒ _" ⇀
(SML) "Rat.mult ((_)) (Rat.inv ((_)))" |
constant "rat_of_integer :: integer ⇒ rat" ⇀
(SML) "Rat.of'_int" |
constant "abs :: rat ⇒ _" ⇀
(SML) "Rat.abs" |
constant "0 :: rat" ⇀
(SML) "!(Rat.make (0, 1))" |
constant "1 :: rat" ⇀
(SML) "!(Rat.make (1, 1))" |
constant "uminus :: rat ⇒ rat" ⇀
(SML) "Rat.neg" |
constant "HOL.equal :: rat ⇒ _" ⇀
(SML) "!((_ : Rat.rat) = _)" |
constant "quotient_of'" ⇀
(SML) "Rat.dest"
end
Theory Buchberger_Examples
section ‹Sample Computations with Buchberger's Algorithm›
theory Buchberger_Examples
imports Buchberger Algorithm_Schema_Impl Code_Target_Rat
begin
lemma (in gd_term) compute_trd_aux [code]:
"trd_aux fs p r =
(if is_zero p then
r
else
case find_adds fs (lt p) of
None ⇒ trd_aux fs (tail p) (plus_monomial_less r (lc p) (lt p))
| Some f ⇒ trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r
)"
by (simp only: trd_aux.simps[of fs p r] plus_monomial_less_def is_zero_def)
subsection ‹Scalar Polynomials›
global_interpretation punit': gd_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term"
rewrites "punit.adds_term = (adds)"
and "punit.pp_of_term = (λx. x)"
and "punit.component_of_term = (λ_. ())"
and "punit.monom_mult = monom_mult_punit"
and "punit.mult_scalar = mult_scalar_punit"
and "punit'.punit.min_term = min_term_punit"
and "punit'.punit.lt = lt_punit cmp_term"
and "punit'.punit.lc = lc_punit cmp_term"
and "punit'.punit.tail = tail_punit cmp_term"
and "punit'.punit.ord_p = ord_p_punit cmp_term"
and "punit'.punit.ord_strict_p = ord_strict_p_punit cmp_term"
for cmp_term :: "('a::nat, 'b::{nat,add_wellorder}) pp nat_term_order"
defines find_adds_punit = punit'.punit.find_adds
and trd_aux_punit = punit'.punit.trd_aux
and trd_punit = punit'.punit.trd
and spoly_punit = punit'.punit.spoly
and count_const_lt_components_punit = punit'.punit.count_const_lt_components
and count_rem_components_punit = punit'.punit.count_rem_components
and const_lt_component_punit = punit'.punit.const_lt_component
and full_gb_punit = punit'.punit.full_gb
and add_pairs_single_sorted_punit = punit'.punit.add_pairs_single_sorted
and add_pairs_punit = punit'.punit.add_pairs
and canon_pair_order_aux_punit = punit'.punit.canon_pair_order_aux
and canon_basis_order_punit = punit'.punit.canon_basis_order
and new_pairs_sorted_punit = punit'.punit.new_pairs_sorted
and product_crit_punit = punit'.punit.product_crit
and chain_ncrit_punit = punit'.punit.chain_ncrit
and chain_ocrit_punit = punit'.punit.chain_ocrit
and apply_icrit_punit = punit'.punit.apply_icrit
and apply_ncrit_punit = punit'.punit.apply_ncrit
and apply_ocrit_punit = punit'.punit.apply_ocrit
and trdsp_punit = punit'.punit.trdsp
and gb_sel_punit = punit'.punit.gb_sel
and gb_red_aux_punit = punit'.punit.gb_red_aux
and gb_red_punit = punit'.punit.gb_red
and gb_aux_punit = punit'.punit.gb_aux_punit
and gb_punit = punit'.punit.gb_punit
subgoal by (fact gd_powerprod_ord_pp_punit)
subgoal by (fact punit_adds_term)
subgoal by (simp add: id_def)
subgoal by (fact punit_component_of_term)
subgoal by (simp only: monom_mult_punit_def)
subgoal by (simp only: mult_scalar_punit_def)
subgoal using min_term_punit_def by fastforce
subgoal by (simp only: lt_punit_def ord_pp_punit_alt)
subgoal by (simp only: lc_punit_def ord_pp_punit_alt)
subgoal by (simp only: tail_punit_def ord_pp_punit_alt)
subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt)
subgoal by (simp only: ord_strict_p_punit_def ord_pp_strict_punit_alt)
done
lemma compute_spoly_punit [code]:
"spoly_punit to p q = (let t1 = lt_punit to p; t2 = lt_punit to q; l = lcs t1 t2 in
(monom_mult_punit (1 / lc_punit to p) (l - t1) p) - (monom_mult_punit (1 / lc_punit to q) (l - t2) q))"
by (simp add: punit'.punit.spoly_def Let_def punit'.punit.lc_def)
lemma compute_trd_punit [code]: "trd_punit to fs p = trd_aux_punit to fs p (change_ord to 0)"
by (simp only: punit'.punit.trd_def change_ord_def)
experiment begin interpretation trivariate⇩0_rat .
lemma
"lt_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = sparse⇩0 [(0, 2), (2, 3)]"
by eval
lemma
"lc_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = 1"
by eval
lemma
"tail_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = 3 * X⇧2 * Y"
by eval
lemma
"ord_strict_p_punit DRLEX (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2) (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2)"
by eval
lemma
"trd_punit DRLEX [Y⇧2 * Z + 2 * Y * Z ^ 3] (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z ^ 3) =
X⇧2 * Z ^ 4 + Y ^ 4 * Z"
by eval
lemma
"spoly_punit DRLEX (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2) (Y⇧2 * Z + 2 * Z ^ 3) =
-2 * Y ^ 3 * Z⇧2 - (C⇩0 (1 / 2)) * X⇧2 * Y⇧2 * Z⇧2"
by eval
lemma
"gb_punit DRLEX
[
(X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2, ()),
(Y⇧2 * Z + 2 * Z ^ 3, ())
] () =
[
(-2 * Y ^ 3 * Z⇧2 - (C⇩0 (1 / 2)) * X⇧2 * Y⇧2 * Z⇧2, ()),
(X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2, ()),
(Y⇧2 * Z + 2 * Z ^ 3, ()),
(- (C⇩0 (1 / 2)) * X⇧2 * Y ^ 4 * Z - 2 * Y ^ 5 * Z, ())
]"
by eval
lemma
"gb_punit DRLEX
[
(X⇧2 * Z⇧2 - Y, ()),
(Y⇧2 * Z - 1, ())
] () =
[
(- (Y ^ 3) + X⇧2 * Z, ()),
(X⇧2 * Z⇧2 - Y, ()),
(Y⇧2 * Z - 1, ())
]"
by eval
lemma
"gb_punit DRLEX
[
(X ^ 3 - X * Y * Z⇧2, ()),
(Y⇧2 * Z - 1, ())
] () =
[
(- (X ^ 3 * Y) + X * Z, ()),
(X ^ 3 - X * Y * Z⇧2, ()),
(Y⇧2 * Z - 1, ()),
(- (X * Z ^ 3) + X ^ 5, ())
]"
by eval
lemma
"gb_punit DRLEX
[
(X⇧2 + Y⇧2 + Z⇧2 - 1, ()),
(X * Y - Z - 1, ()),
(Y⇧2 + X, ()),
(Z⇧2 + X, ())
] () =
[
(1, ())
]"
by eval
end
value [code] "length (gb_punit DRLEX (map (λp. (p, ())) ((katsura DRLEX 2)::(_ ⇒⇩0 rat) list)) ())"
value [code] "length (gb_punit DRLEX (map (λp. (p, ())) ((cyclic DRLEX 5)::(_ ⇒⇩0 rat) list)) ())"
subsection ‹Vector Polynomials›
text ‹We must define the following four constants outside the global interpretation, since otherwise
their types are too general.›
definition splus_pprod :: "('a::nat, 'b::nat) pp ⇒ _"
where "splus_pprod = pprod.splus"
definition monom_mult_pprod :: "'c::semiring_0 ⇒ ('a::nat, 'b::nat) pp ⇒ _"
where "monom_mult_pprod = pprod.monom_mult"
definition mult_scalar_pprod :: "(('a::nat, 'b::nat) pp ⇒⇩0 'c::semiring_0) ⇒ _"
where "mult_scalar_pprod = pprod.mult_scalar"
definition adds_term_pprod :: "(('a::nat, 'b::nat) pp × _) ⇒ _"
where "adds_term_pprod = pprod.adds_term"
global_interpretation pprod': gd_nat_term "λx::('a, 'b) pp × 'c. x" "λx. x" cmp_term
rewrites "pprod.pp_of_term = fst"
and "pprod.component_of_term = snd"
and "pprod.splus = splus_pprod"
and "pprod.monom_mult = monom_mult_pprod"
and "pprod.mult_scalar = mult_scalar_pprod"
and "pprod.adds_term = adds_term_pprod"
for cmp_term :: "(('a::nat, 'b::nat) pp × 'c::{nat,the_min}) nat_term_order"
defines shift_map_keys_pprod = pprod'.shift_map_keys
and min_term_pprod = pprod'.min_term
and lt_pprod = pprod'.lt
and lc_pprod = pprod'.lc
and tail_pprod = pprod'.tail
and comp_opt_p_pprod = pprod'.comp_opt_p
and ord_p_pprod = pprod'.ord_p
and ord_strict_p_pprod = pprod'.ord_strict_p
and find_adds_pprod = pprod'.find_adds
and trd_aux_pprod= pprod'.trd_aux
and trd_pprod = pprod'.trd
and spoly_pprod = pprod'.spoly
and count_const_lt_components_pprod = pprod'.count_const_lt_components
and count_rem_components_pprod = pprod'.count_rem_components
and const_lt_component_pprod = pprod'.const_lt_component
and full_gb_pprod = pprod'.full_gb
and keys_to_list_pprod = pprod'.keys_to_list
and Keys_to_list_pprod = pprod'.Keys_to_list
and add_pairs_single_sorted_pprod = pprod'.add_pairs_single_sorted
and add_pairs_pprod = pprod'.add_pairs
and canon_pair_order_aux_pprod = pprod'.canon_pair_order_aux
and canon_basis_order_pprod = pprod'.canon_basis_order
and new_pairs_sorted_pprod = pprod'.new_pairs_sorted
and component_crit_pprod = pprod'.component_crit
and chain_ncrit_pprod = pprod'.chain_ncrit
and chain_ocrit_pprod = pprod'.chain_ocrit
and apply_icrit_pprod = pprod'.apply_icrit
and apply_ncrit_pprod = pprod'.apply_ncrit
and apply_ocrit_pprod = pprod'.apply_ocrit
and trdsp_pprod = pprod'.trdsp
and gb_sel_pprod = pprod'.gb_sel
and gb_red_aux_pprod = pprod'.gb_red_aux
and gb_red_pprod = pprod'.gb_red
and gb_aux_pprod = pprod'.gb_aux
and gb_pprod = pprod'.gb
subgoal by (fact gd_nat_term_id)
subgoal by (fact pprod_pp_of_term)
subgoal by (fact pprod_component_of_term)
subgoal by (simp only: splus_pprod_def)
subgoal by (simp only: monom_mult_pprod_def)
subgoal by (simp only: mult_scalar_pprod_def)
subgoal by (simp only: adds_term_pprod_def)
done
lemma compute_adds_term_pprod [code]:
"adds_term_pprod u v = (snd u = snd v ∧ adds_pp_add_linorder (fst u) (fst v))"
by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def)
lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)"
by (simp add: splus_pprod_def pprod.splus_def)
lemma compute_shift_map_keys_pprod [code abstract]:
"list_of_oalist_ntm (shift_map_keys_pprod t f xs) = map_raw (λ(k, v). (splus_pprod t k, f v)) (list_of_oalist_ntm xs)"
by (simp add: pprod'.list_of_oalist_shift_keys case_prod_beta')
lemma compute_trd_pprod [code]: "trd_pprod to fs p = trd_aux_pprod to fs p (change_ord to 0)"
by (simp only: pprod'.trd_def change_ord_def)
lemmas [code] = conversep_iff
definition Vec⇩0 :: "nat ⇒ (('a, nat) pp ⇒⇩0 'b) ⇒ (('a::nat, nat) pp × nat) ⇒⇩0 'b::semiring_1" where
"Vec⇩0 i p = mult_scalar_pprod p (Poly_Mapping.single (0, i) 1)"
experiment begin interpretation trivariate⇩0_rat .
lemma
"ord_p_pprod (POT DRLEX) (Vec⇩0 1 (X⇧2 * Z) + Vec⇩0 0 (2 * Y ^ 3 * Z⇧2)) (Vec⇩0 1 (X⇧2 * Z⇧2 + 2 * Y ^ 3 * Z⇧2))"
by eval
lemma
"tail_pprod (POT DRLEX) (Vec⇩0 1 (X⇧2 * Z) + Vec⇩0 0 (2 * Y ^ 3 * Z⇧2)) = Vec⇩0 0 (2 * Y ^ 3 * Z⇧2)"
by eval
lemma
"lt_pprod (POT DRLEX) (Vec⇩0 1 (X⇧2 * Z) + Vec⇩0 0 (2 * Y ^ 3 * Z⇧2)) = (sparse⇩0 [(0, 2), (2, 1)], 1)"
by eval
lemma
"keys (Vec⇩0 0 (X⇧2 * Z ^ 3) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2)) =
{(sparse⇩0 [(0, 2), (2, 3)], 0), (sparse⇩0 [(1, 3), (2, 2)], 1)}"
by eval
lemma
"keys (Vec⇩0 0 (X⇧2 * Z ^ 3) + Vec⇩0 2 (2 * Y ^ 3 * Z⇧2)) =
{(sparse⇩0 [(0, 2), (2, 3)], 0), (sparse⇩0 [(1, 3), (2, 2)], 2)}"
by eval
lemma
"Vec⇩0 1 (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2) + Vec⇩0 3 (X⇧2 * Z ^ 4) + Vec⇩0 1 (- 2 * Y ^ 3 * Z⇧2) =
Vec⇩0 1 (X⇧2 * Z ^ 7) + Vec⇩0 3 (X⇧2 * Z ^ 4)"
by eval
lemma
"lookup (Vec⇩0 0 (X⇧2 * Z ^ 7) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2 + 2)) (sparse⇩0 [(0, 2), (2, 7)], 0) = 1"
by eval
lemma
"lookup (Vec⇩0 0 (X⇧2 * Z ^ 7) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2 + 2)) (sparse⇩0 [(0, 2), (2, 7)], 1) = 0"
by eval
lemma
"Vec⇩0 0 (0 * X^2 * Z^7) + Vec⇩0 1 (0 * Y^3*Z⇧2) = 0"
by eval
lemma
"monom_mult_pprod 3 (sparse⇩0 [(1, 2::nat)]) (Vec⇩0 0 (X⇧2 * Z) + Vec⇩0 1 (2 * Y ^ 3 * Z⇧2)) =
Vec⇩0 0 (3 * Y⇧2 * Z * X⇧2) + Vec⇩0 1 (6 * Y ^ 5 * Z⇧2)"
by eval
lemma
"trd_pprod DRLEX [Vec⇩0 0 (Y⇧2 * Z + 2 * Y * Z ^ 3)] (Vec⇩0 0 (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z ^ 3)) =
Vec⇩0 0 (X⇧2 * Z ^ 4 + Y ^ 4 * Z)"
by eval
lemma
"length (gb_pprod (POT DRLEX)
[
(Vec⇩0 0 (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2), ()),
(Vec⇩0 0 (Y⇧2 * Z + 2 * Z ^ 3), ())
] ()) = 4"
by eval
end
end
Theory More_MPoly_Type_Class
section ‹Further Properties of Multivariate Polynomials›
theory More_MPoly_Type_Class
imports Polynomials.MPoly_Type_Class_Ordered General
begin
text ‹Some further general properties of (ordered) multivariate polynomials needed for Gr\"obner
bases. This theory is an extension of @{theory Polynomials.MPoly_Type_Class_Ordered}.›
subsection ‹Modules and Linear Hulls›
context module
begin
lemma span_listE:
assumes "p ∈ span (set bs)"
obtains qs where "length qs = length bs" and "p = sum_list (map2 (*s) qs bs)"
proof -
have "finite (set bs)" ..
from this assms obtain q where p: "p = (∑b∈set bs. (q b) *s b)" by (rule span_finiteE)
let ?qs = "map_dup q (λ_. 0) bs"
show ?thesis
proof
show "length ?qs = length bs" by simp
next
let ?zs = "zip (map q (remdups bs)) (remdups bs)"
have *: "distinct ?zs" by (rule distinct_zipI2, rule distinct_remdups)
have inj: "inj_on (λb. (q b, b)) (set bs)" by (rule, simp)
have "p = (∑(q, b)←?zs. q *s b)"
by (simp add: sum_list_distinct_conv_sum_set[OF *] set_zip_map1 p comm_monoid_add_class.sum.reindex[OF inj])
also have "... = (∑(q, b)←(filter (λ(q, b). q ≠ 0) ?zs). q *s b)"
by (rule monoid_add_class.sum_list_map_filter[symmetric], auto)
also have "... = (∑(q, b)←(filter (λ(q, b). q ≠ 0) (zip ?qs bs)). q *s b)"
by (simp only: filter_zip_map_dup_const)
also have "... = (∑(q, b)←zip ?qs bs. q *s b)"
by (rule monoid_add_class.sum_list_map_filter, auto)
finally show "p = (∑(q, b)←zip ?qs bs. q *s b)" .
qed
qed
lemma span_listI: "sum_list (map2 (*s) qs bs) ∈ span (set bs)"
proof (induct qs arbitrary: bs)
case Nil
show ?case by (simp add: span_zero)
next
case step: (Cons q qs)
show ?case
proof (simp add: zip_Cons1 span_zero split: list.split, intro allI impI)
fix a as
have "sum_list (map2 (*s) qs as) ∈ span (insert a (set as))" (is "?x ∈ ?A")
by (rule, fact step, rule span_mono, auto)
moreover have "a ∈ ?A" by (rule span_base) simp
ultimately show "q *s a + ?x ∈ ?A" by (intro span_add span_scale)
qed
qed
end
lemma (in term_powerprod) monomial_1_in_pmdlI:
assumes "(f::_ ⇒⇩0 'b::field) ∈ pmdl F" and "keys f = {t}"
shows "monomial 1 t ∈ pmdl F"
proof -
define c where "c ≡ lookup f t"
from assms(2) have f_eq: "f = monomial c t" unfolding c_def
by (metis (mono_tags, lifting) Diff_insert_absorb cancel_comm_monoid_add_class.add_cancel_right_right
plus_except insert_absorb insert_not_empty keys_eq_empty keys_except)
from assms(2) have "c ≠ 0"
unfolding c_def by auto
hence "monomial 1 t = monom_mult (1 / c) 0 f" by (simp add: f_eq monom_mult_monomial term_simps)
also from assms(1) have "... ∈ pmdl F" by (rule pmdl_closed_monom_mult)
finally show ?thesis .
qed
subsection ‹Ordered Polynomials›
context ordered_term
begin
subsubsection ‹Sets of Leading Terms and -Coefficients›
definition lt_set :: "('t, 'b::zero) poly_mapping set ⇒ 't set" where
"lt_set F = lt ` (F - {0})"
definition lc_set :: "('t, 'b::zero) poly_mapping set ⇒ 'b set" where
"lc_set F = lc ` (F - {0})"
lemma lt_setI:
assumes "f ∈ F" and "f ≠ 0"
shows "lt f ∈ lt_set F"
unfolding lt_set_def using assms by simp
lemma lt_setE:
assumes "t ∈ lt_set F"
obtains f where "f ∈ F" and "f ≠ 0" and "lt f = t"
using assms unfolding lt_set_def by auto
lemma lt_set_iff:
shows "t ∈ lt_set F ⟷ (∃f∈F. f ≠ 0 ∧ lt f = t)"
unfolding lt_set_def by auto
lemma lc_setI:
assumes "f ∈ F" and "f ≠ 0"
shows "lc f ∈ lc_set F"
unfolding lc_set_def using assms by simp
lemma lc_setE:
assumes "c ∈ lc_set F"
obtains f where "f ∈ F" and "f ≠ 0" and "lc f = c"
using assms unfolding lc_set_def by auto
lemma lc_set_iff:
shows "c ∈ lc_set F ⟷ (∃f∈F. f ≠ 0 ∧ lc f = c)"
unfolding lc_set_def by auto
lemma lc_set_nonzero:
shows "0 ∉ lc_set F"
proof
assume "0 ∈ lc_set F"
then obtain f where "f ∈ F" and "f ≠ 0" and "lc f = 0" by (rule lc_setE)
from ‹f ≠ 0› have "lc f ≠ 0" by (rule lc_not_0)
from this ‹lc f = 0› show False ..
qed
lemma lt_sum_distinct_eq_Max:
assumes "finite I" and "sum p I ≠ 0"
and "⋀i1 i2. i1 ∈ I ⟹ i2 ∈ I ⟹ p i1 ≠ 0 ⟹ p i2 ≠ 0 ⟹ lt (p i1) = lt (p i2) ⟹ i1 = i2"
shows "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))"
proof -
have "¬ p ` I ⊆ {0}"
proof
assume "p ` I ⊆ {0}"
hence "sum p I = 0" by (rule sum_poly_mapping_eq_zeroI)
with assms(2) show False ..
qed
from assms(1) this assms(3) show ?thesis
proof (induct I)
case empty
from empty(1) show ?case by simp
next
case (insert x I)
show ?case
proof (cases "p ` I ⊆ {0}")
case True
hence "p ` I - {0} = {}" by simp
have "p x ≠ 0"
proof
assume "p x = 0"
with True have " p ` insert x I ⊆ {0}" by simp
with insert(4) show False ..
qed
hence "insert (p x) (p ` I) - {0} = insert (p x) (p ` I - {0})" by auto
hence "lt_set (p ` insert x I) = {lt (p x)}" by (simp add: lt_set_def ‹p ` I - {0} = {}›)
hence eq1: "ord_term_lin.Max (lt_set (p ` insert x I)) = lt (p x)" by simp
have eq2: "sum p I = 0"
proof (rule ccontr)
assume "sum p I ≠ 0"
then obtain y where "y ∈ I" and "p y ≠ 0" by (rule sum.not_neutral_contains_not_neutral)
with True show False by auto
qed
show ?thesis by (simp only: eq1 sum.insert[OF insert(1) insert(2)], simp add: eq2)
next
case False
hence IH: "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))"
proof (rule insert(3))
fix i1 i2
assume "i1 ∈ I" and "i2 ∈ I"
hence "i1 ∈ insert x I" and "i2 ∈ insert x I" by simp_all
moreover assume "p i1 ≠ 0" and "p i2 ≠ 0" and "lt (p i1) = lt (p i2)"
ultimately show "i1 = i2" by (rule insert(5))
qed
show ?thesis
proof (cases "p x = 0")
case True
hence eq: "lt_set (p ` insert x I) = lt_set (p ` I)" by (simp add: lt_set_def)
show ?thesis by (simp only: eq, simp add: sum.insert[OF insert(1) insert(2)] True, fact IH)
next
case False
hence eq1: "lt_set (p ` insert x I) = insert (lt (p x)) (lt_set (p ` I))"
by (auto simp add: lt_set_def)
from insert(1) have "finite (lt_set (p ` I))" by (simp add: lt_set_def)
moreover from ‹¬ p ` I ⊆ {0}› have "lt_set (p ` I) ≠ {}" by (simp add: lt_set_def)
ultimately have eq2: "ord_term_lin.Max (insert (lt (p x)) (lt_set (p ` I))) =
ord_term_lin.max (lt (p x)) (ord_term_lin.Max (lt_set (p ` I)))"
by (rule ord_term_lin.Max_insert)
show ?thesis
proof (simp only: eq1, simp add: sum.insert[OF insert(1) insert(2)] eq2 IH[symmetric],
rule lt_plus_distinct_eq_max, rule)
assume *: "lt (p x) = lt (sum p I)"
have "lt (p x) ∈ lt_set (p ` I)" by (simp only: * IH, rule ord_term_lin.Max_in, fact+)
then obtain f where "f ∈ p ` I" and "f ≠ 0" and ltf: "lt f = lt (p x)" by (rule lt_setE)
from this(1) obtain y where "y ∈ I" and "f = p y" ..
from this(2) ‹f ≠ 0› ltf have "p y ≠ 0" and lt_eq: "lt (p y) = lt (p x)" by simp_all
from _ _ this(1) ‹p x ≠ 0› this(2) have "y = x"
proof (rule insert(5))
from ‹y ∈ I› show "y ∈ insert x I" by simp
next
show "x ∈ insert x I" by simp
qed
with ‹y ∈ I› have "x ∈ I" by simp
with ‹x ∉ I› show False ..
qed
qed
qed
qed
qed
lemma lt_sum_distinct_in_lt_set:
assumes "finite I" and "sum p I ≠ 0"
and "⋀i1 i2. i1 ∈ I ⟹ i2 ∈ I ⟹ p i1 ≠ 0 ⟹ p i2 ≠ 0 ⟹ lt (p i1) = lt (p i2) ⟹ i1 = i2"
shows "lt (sum p I) ∈ lt_set (p ` I)"
proof -
have "¬ p ` I ⊆ {0}"
proof
assume "p ` I ⊆ {0}"
hence "sum p I = 0" by (rule sum_poly_mapping_eq_zeroI)
with assms(2) show False ..
qed
have "lt (sum p I) = ord_term_lin.Max (lt_set (p ` I))"
by (rule lt_sum_distinct_eq_Max, fact+)
also have "... ∈ lt_set (p ` I)"
proof (rule ord_term_lin.Max_in)
from assms(1) show "finite (lt_set (p ` I))" by (simp add: lt_set_def)
next
from ‹¬ p ` I ⊆ {0}› show "lt_set (p ` I) ≠ {}" by (simp add: lt_set_def)
qed
finally show ?thesis .
qed
subsubsection ‹Monicity›
definition monic :: "('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::field)" where
"monic p = monom_mult (1 / lc p) 0 p"
definition is_monic_set :: "('t ⇒⇩0 'b::field) set ⇒ bool" where
"is_monic_set B ≡ (∀b∈B. b ≠ 0 ⟶ lc b = 1)"
lemma lookup_monic: "lookup (monic p) v = (lookup p v) / lc p"
proof -
have "lookup (monic p) (0 ⊕ v) = (1 / lc p) * (lookup p v)" unfolding monic_def
by (rule lookup_monom_mult_plus)
thus ?thesis by (simp add: term_simps)
qed
lemma lookup_monic_lt:
assumes "p ≠ 0"
shows "lookup (monic p) (lt p) = 1"
unfolding monic_def
proof -
from assms have "lc p ≠ 0" by (rule lc_not_0)
hence "1 / lc p ≠ 0" by simp
let ?q = "monom_mult (1 / lc p) 0 p"
have "lookup ?q (0 ⊕ lt p) = (1 / lc p) * (lookup p (lt p))" by (rule lookup_monom_mult_plus)
also have "... = (1 / lc p) * lc p" unfolding lc_def ..
also have "... = 1" using ‹lc p ≠ 0› by simp
finally have "lookup ?q (0 ⊕ lt p) = 1" .
thus "lookup ?q (lt p) = 1" by (simp add: term_simps)
qed
lemma monic_0 [simp]: "monic 0 = 0"
unfolding monic_def by (rule monom_mult_zero_right)
lemma monic_0_iff: "(monic p = 0) ⟷ (p = 0)"
proof
assume "monic p = 0"
show "p = 0"
proof (rule ccontr)
assume "p ≠ 0"
hence "lookup (monic p) (lt p) = 1" by (rule lookup_monic_lt)
with ‹monic p = 0› have "lookup 0 (lt p) = (1::'b)" by simp
thus False by simp
qed
next
assume p0: "p = 0"
show "monic p = 0" unfolding p0 by (fact monic_0)
qed
lemma keys_monic [simp]: "keys (monic p) = keys p"
proof (cases "p = 0")
case True
show ?thesis unfolding True monic_0 ..
next
case False
hence "lc p ≠ 0" by (rule lc_not_0)
show ?thesis by (rule set_eqI, simp add: in_keys_iff lookup_monic ‹lc p ≠ 0›)
qed
lemma lt_monic [simp]: "lt (monic p) = lt p"
proof (cases "p = 0")
case True
show ?thesis unfolding True monic_0 ..
next
case False
have "lt (monom_mult (1 / lc p) 0 p) = 0 ⊕ lt p"
proof (rule lt_monom_mult)
from False have "lc p ≠ 0" by (rule lc_not_0)
thus "1 / lc p ≠ 0" by simp
qed fact
thus ?thesis by (simp add: monic_def term_simps)
qed
lemma lc_monic:
assumes "p ≠ 0"
shows "lc (monic p) = 1"
using assms by (simp add: lc_def lookup_monic_lt)
lemma mult_lc_monic:
assumes "p ≠ 0"
shows "monom_mult (lc p) 0 (monic p) = p" (is "?q = p")
proof (rule poly_mapping_eqI)
fix v
from assms have "lc p ≠ 0" by (rule lc_not_0)
have "lookup ?q (0 ⊕ v) = (lc p) * (lookup (monic p) v)" by (rule lookup_monom_mult_plus)
also have "... = (lc p) * ((lookup p v) / lc p)" by (simp add: lookup_monic)
also have "... = lookup p v" using ‹lc p ≠ 0› by simp
finally show "lookup ?q v = lookup p v" by (simp add: term_simps)
qed
lemma is_monic_setI:
assumes "⋀b. b ∈ B ⟹ b ≠ 0 ⟹ lc b = 1"
shows "is_monic_set B"
unfolding is_monic_set_def using assms by auto
lemma is_monic_setD:
assumes "is_monic_set B" and "b ∈ B" and "b ≠ 0"
shows "lc b = 1"
using assms unfolding is_monic_set_def by auto
lemma Keys_image_monic [simp]: "Keys (monic ` A) = Keys A"
by (simp add: Keys_def)
lemma image_monic_is_monic_set: "is_monic_set (monic ` A)"
proof (rule is_monic_setI)
fix p
assume pin: "p ∈ monic ` A" and "p ≠ 0"
from pin obtain p' where p_def: "p = monic p'" and "p' ∈ A" ..
from ‹p ≠ 0› have "p' ≠ 0" unfolding p_def monic_0_iff .
thus "lc p = 1" unfolding p_def by (rule lc_monic)
qed
lemma pmdl_image_monic [simp]: "pmdl (monic ` B) = pmdl B"
proof
show "pmdl (monic ` B) ⊆ pmdl B"
proof
fix p
assume "p ∈ pmdl (monic ` B)"
thus "p ∈ pmdl B"
proof (induct p rule: pmdl_induct)
case base: module_0
show ?case by (fact pmdl.span_zero)
next
case ind: (module_plus a b c t)
from ind(3) obtain b' where b_def: "b = monic b'" and "b' ∈ B" ..
have eq: "b = monom_mult (1 / lc b') 0 b'" by (simp only: b_def monic_def)
show ?case unfolding eq monom_mult_assoc
by (rule pmdl.span_add, fact, rule monom_mult_in_pmdl, fact)
qed
qed
next
show "pmdl B ⊆ pmdl (monic ` B)"
proof
fix p
assume "p ∈ pmdl B"
thus "p ∈ pmdl (monic ` B)"
proof (induct p rule: pmdl_induct)
case base: module_0
show ?case by (fact pmdl.span_zero)
next
case ind: (module_plus a b c t)
show ?case
proof (cases "b = 0")
case True
from ind(2) show ?thesis by (simp add: True)
next
case False
let ?b = "monic b"
from ind(3) have "?b ∈ monic ` B" by (rule imageI)
have "a + monom_mult c t (monom_mult (lc b) 0 ?b) ∈ pmdl (monic ` B)"
unfolding monom_mult_assoc
by (rule pmdl.span_add, fact, rule monom_mult_in_pmdl, fact)
thus ?thesis unfolding mult_lc_monic[OF False] .
qed
qed
qed
qed
end
end
Theory Auto_Reduction
section ‹Auto-reducing Lists of Polynomials›
theory Auto_Reduction
imports Reduction More_MPoly_Type_Class
begin
subsection ‹Reduction and Monic Sets›
context ordered_term
begin
lemma is_red_monic: "is_red B (monic p) ⟷ is_red B p"
unfolding is_red_adds_iff keys_monic ..
lemma red_image_monic [simp]: "red (monic ` B) = red B"
proof (rule, rule)
fix p q
show "red (monic ` B) p q ⟷ red B p q"
proof
assume "red (monic ` B) p q"
then obtain f t where "f ∈ monic ` B" and *: "red_single p q f t" by (rule red_setE)
from this(1) obtain g where "g ∈ B" and "f = monic g" ..
from * have "f ≠ 0" by (simp add: red_single_def)
hence "g ≠ 0" by (simp add: monic_0_iff ‹f = monic g›)
hence "lc g ≠ 0" by (rule lc_not_0)
have eq: "monom_mult (lc g) 0 f = g" by (simp add: ‹f = monic g› mult_lc_monic[OF ‹g ≠ 0›])
from ‹g ∈ B› show "red B p q"
proof (rule red_setI)
from * ‹lc g ≠ 0› have "red_single p q (monom_mult (lc g) 0 f) t" by (rule red_single_mult_const)
thus "red_single p q g t" by (simp only: eq)
qed
next
assume "red B p q"
then obtain f t where "f ∈ B" and *: "red_single p q f t" by (rule red_setE)
from * have "f ≠ 0" by (simp add: red_single_def)
hence "lc f ≠ 0" by (rule lc_not_0)
hence "1 / lc f ≠ 0" by simp
from ‹f ∈ B› have "monic f ∈ monic ` B" by (rule imageI)
thus "red (monic ` B) p q"
proof (rule red_setI)
from * ‹1 / lc f ≠ 0› show "red_single p q (monic f) t" unfolding monic_def
by (rule red_single_mult_const)
qed
qed
qed
lemma is_red_image_monic [simp]: "is_red (monic ` B) p ⟷ is_red B p"
by (simp add: is_red_def)
subsection ‹Minimal Bases and Auto-reduced Bases›
definition is_auto_reduced :: "('t ⇒⇩0 'b::field) set ⇒ bool" where
"is_auto_reduced B ≡ (∀b∈B. ¬ is_red (B - {b}) b)"
definition is_minimal_basis :: "('t ⇒⇩0 'b::zero) set ⇒ bool" where
"is_minimal_basis B ⟷ (0 ∉ B ∧ (∀p q. p ∈ B ⟶ q ∈ B ⟶ p ≠ q ⟶ ¬ lt p adds⇩t lt q))"
lemma is_auto_reducedD:
assumes "is_auto_reduced B" and "b ∈ B"
shows "¬ is_red (B - {b}) b"
using assms unfolding is_auto_reduced_def by auto
text ‹The converse of the following lemma is only true if @{term B} is minimal!›
lemma image_monic_is_auto_reduced:
assumes "is_auto_reduced B"
shows "is_auto_reduced (monic ` B)"
unfolding is_auto_reduced_def
proof
fix b
assume "b ∈ monic ` B"
then obtain b' where b_def: "b = monic b'" and "b' ∈ B" ..
from assms ‹b' ∈ B› have nred: "¬ is_red (B - {b'}) b'" by (rule is_auto_reducedD)
show "¬ is_red ((monic ` B) - {b}) b"
proof
assume red: "is_red ((monic ` B) - {b}) b"
have "(monic ` B) - {b} ⊆ monic ` (B - {b'})" unfolding b_def by auto
with red have "is_red (monic ` (B - {b'})) b" by (rule is_red_subset)
hence "is_red (B - {b'}) b'" unfolding b_def is_red_monic is_red_image_monic .
with nred show False ..
qed
qed
lemma is_minimal_basisI:
assumes "⋀p. p ∈ B ⟹ p ≠ 0" and "⋀p q. p ∈ B ⟹ q ∈ B ⟹ p ≠ q ⟹ ¬ lt p adds⇩t lt q"
shows "is_minimal_basis B"
unfolding is_minimal_basis_def using assms by auto
lemma is_minimal_basisD1:
assumes "is_minimal_basis B" and "p ∈ B"
shows "p ≠ 0"
using assms unfolding is_minimal_basis_def by auto
lemma is_minimal_basisD2:
assumes "is_minimal_basis B" and "p ∈ B" and "q ∈ B" and "p ≠ q"
shows "¬ lt p adds⇩t lt q"
using assms unfolding is_minimal_basis_def by auto
lemma is_minimal_basisD3:
assumes "is_minimal_basis B" and "p ∈ B" and "q ∈ B" and "p ≠ q"
shows "¬ lt q adds⇩t lt p"
using assms unfolding is_minimal_basis_def by auto
lemma is_minimal_basis_subset:
assumes "is_minimal_basis B" and "A ⊆ B"
shows "is_minimal_basis A"
proof (intro is_minimal_basisI)
fix p
assume "p ∈ A"
with ‹A ⊆ B› have "p ∈ B" ..
with ‹is_minimal_basis B› show "p ≠ 0" by (rule is_minimal_basisD1)
next
fix p q
assume "p ∈ A" and "q ∈ A" and "p ≠ q"
from ‹p ∈ A› and ‹q ∈ A› have "p ∈ B" and "q ∈ B" using ‹A ⊆ B› by auto
from ‹is_minimal_basis B› this ‹p ≠ q› show " ¬ lt p adds⇩t lt q" by (rule is_minimal_basisD2)
qed
lemma nadds_red:
assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and red: "red B p r"
shows "r ≠ 0 ∧ lt r = lt p"
proof -
from red obtain q t where "q ∈ B" and rs: "red_single p r q t" by (rule red_setE)
from rs have "q ≠ 0" and "lookup p (t ⊕ lt q) ≠ 0"
and r_def: "r = p - monom_mult (lookup p (t ⊕ lt q) / lc q) t q" unfolding red_single_def by simp_all
have "t ⊕ lt q ≼⇩t lt p" by (rule lt_max, fact)
moreover have "t ⊕ lt q ≠ lt p"
proof
assume "t ⊕ lt q = lt p"
hence "lt q adds⇩t lt p" by (metis adds_term_triv)
with nadds[OF ‹q ∈ B›] show False ..
qed
ultimately have "t ⊕ lt q ≺⇩t lt p" by simp
let ?m = "monom_mult (lookup p (t ⊕ lt q) / lc q) t q"
from ‹lookup p (t ⊕ lt q) ≠ 0› lc_not_0[OF ‹q ≠ 0›] have c0: "lookup p (t ⊕ lt q) / lc q ≠ 0" by simp
from ‹q ≠ 0› c0 have "?m ≠ 0" by (simp add: monom_mult_eq_zero_iff)
have "lt (-?m) = lt ?m" by (fact lt_uminus)
also have lt1: "lt ?m = t ⊕ lt q" by (rule lt_monom_mult, fact+)
finally have lt2: "lt (-?m) = t ⊕ lt q" .
show ?thesis
proof
show "r ≠ 0"
proof
assume "r = 0"
hence "p = ?m" unfolding r_def by simp
with lt1 ‹t ⊕ lt q ≠ lt p› show False by simp
qed
next
have "lt (-?m + p) = lt p"
proof (rule lt_plus_eqI)
show "lt (-?m) ≺⇩t lt p" unfolding lt2 by fact
qed
thus "lt r = lt p" unfolding r_def by simp
qed
qed
lemma nadds_red_nonzero:
assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and "red B p r"
shows "r ≠ 0"
using nadds_red[OF assms] by simp
lemma nadds_red_lt:
assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and "red B p r"
shows "lt r = lt p"
using nadds_red[OF assms] by simp
lemma nadds_red_rtrancl_lt:
assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and rtrancl: "(red B)⇧*⇧* p r"
shows "lt r = lt p"
using rtrancl
proof (induct rule: rtranclp_induct)
case base
show ?case ..
next
case (step y z)
have "lt z = lt y"
proof (rule nadds_red_lt)
fix q
assume "q ∈ B"
thus "¬ lt q adds⇩t lt y" unfolding ‹lt y = lt p› by (rule nadds)
qed fact
with ‹lt y = lt p› show ?case by simp
qed
lemma nadds_red_rtrancl_nonzero:
assumes nadds: "⋀q. q ∈ B ⟹ ¬ lt q adds⇩t lt p" and "p ≠ 0" and rtrancl: "(red B)⇧*⇧* p r"
shows "r ≠ 0"
using rtrancl
proof (induct rule: rtranclp_induct)
case base
show ?case by fact
next
case (step y z)
from nadds ‹(red B)⇧*⇧* p y› have "lt y = lt p" by (rule nadds_red_rtrancl_lt)
show "z ≠ 0"
proof (rule nadds_red_nonzero)
fix q
assume "q ∈ B"
thus "¬ lt q adds⇩t lt y" unfolding ‹lt y = lt p› by (rule nadds)
qed fact
qed
lemma minimal_basis_red_rtrancl_nonzero:
assumes "is_minimal_basis B" and "p ∈ B" and "(red (B - {p}))⇧*⇧* p r"
shows "r ≠ 0"
proof (rule nadds_red_rtrancl_nonzero)
fix q
assume "q ∈ (B - {p})"
hence "q ∈ B" and "q ≠ p" by auto
show "¬ lt q adds⇩t lt p" by (rule is_minimal_basisD2, fact+)
next
show "p ≠ 0" by (rule is_minimal_basisD1, fact+)
qed fact
lemma minimal_basis_red_rtrancl_lt:
assumes "is_minimal_basis B" and "p ∈ B" and "(red (B - {p}))⇧*⇧* p r"
shows "lt r = lt p"
proof (rule nadds_red_rtrancl_lt)
fix q
assume "q ∈ (B - {p})"
hence "q ∈ B" and "q ≠ p" by auto
show "¬ lt q adds⇩t lt p" by (rule is_minimal_basisD2, fact+)
qed fact
lemma is_minimal_basis_replace:
assumes major: "is_minimal_basis B" and "p ∈ B" and red: "(red (B - {p}))⇧*⇧* p r"
shows "is_minimal_basis (insert r (B - {p}))"
proof (rule is_minimal_basisI)
fix q
assume "q ∈ insert r (B - {p})"
hence "q = r ∨ q ∈ B ∧ q ≠ p" by simp
thus "q ≠ 0"
proof
assume "q = r"
from assms show ?thesis unfolding ‹q = r› by (rule minimal_basis_red_rtrancl_nonzero)
next
assume "q ∈ B ∧ q ≠ p"
hence "q ∈ B" ..
with major show ?thesis by (rule is_minimal_basisD1)
qed
next
fix a b
assume "a ∈ insert r (B - {p})" and "b ∈ insert r (B - {p})" and "a ≠ b"
from assms have ltr: "lt r = lt p" by (rule minimal_basis_red_rtrancl_lt)
from ‹b ∈ insert r (B - {p})› have b: "b = r ∨ b ∈ B ∧ b ≠ p" by simp
from ‹a ∈ insert r (B - {p})› have "a = r ∨ a ∈ B ∧ a ≠ p" by simp
thus "¬ lt a adds⇩t lt b"
proof
assume "a = r"
hence lta: "lt a = lt p" using ltr by simp
from b show ?thesis
proof
assume "b = r"
with ‹a ≠ b› show ?thesis unfolding ‹a = r› by simp
next
assume "b ∈ B ∧ b ≠ p"
hence "b ∈ B" and "p ≠ b" by auto
with major ‹p ∈ B› have "¬ lt p adds⇩t lt b" by (rule is_minimal_basisD2)
thus ?thesis unfolding lta .
qed
next
assume "a ∈ B ∧ a ≠ p"
hence "a ∈ B" and "a ≠ p" by simp_all
from b show ?thesis
proof
assume "b = r"
from major ‹a ∈ B› ‹p ∈ B› ‹a ≠ p› have "¬ lt a adds⇩t lt p" by (rule is_minimal_basisD2)
thus ?thesis unfolding ‹b = r› ltr by simp
next
assume "b ∈ B ∧ b ≠ p"
hence "b ∈ B" ..
from major ‹a ∈ B› ‹b ∈ B› ‹a ≠ b› show ?thesis by (rule is_minimal_basisD2)
qed
qed
qed
subsection ‹Computing Minimal Bases›
definition comp_min_basis :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::zero) list" where
"comp_min_basis xs = filter_min (λx y. lt x adds⇩t lt y) (filter (λx. x ≠ 0) xs)"
lemma comp_min_basis_subset': "set (comp_min_basis xs) ⊆ {x ∈ set xs. x ≠ 0}"
proof -
have "set (comp_min_basis xs) ⊆ set (filter (λx. x ≠ 0) xs)"
unfolding comp_min_basis_def by (rule filter_min_subset)
also have "… = {x ∈ set xs. x ≠ 0}" by simp
finally show ?thesis .
qed
lemma comp_min_basis_subset: "set (comp_min_basis xs) ⊆ set xs"
proof -
have "set (comp_min_basis xs) ⊆ {x ∈ set xs. x ≠ 0}" by (rule comp_min_basis_subset')
also have "... ⊆ set xs" by simp
finally show ?thesis .
qed
lemma comp_min_basis_nonzero: "p ∈ set (comp_min_basis xs) ⟹ p ≠ 0"
using comp_min_basis_subset' by blast
lemma comp_min_basis_adds:
assumes "p ∈ set xs" and "p ≠ 0"
obtains q where "q ∈ set (comp_min_basis xs)" and "lt q adds⇩t lt p"
proof -
let ?rel = "(λx y. lt x adds⇩t lt y)"
have "transp ?rel" by (auto intro!: transpI dest: adds_term_trans)
moreover have "reflp ?rel" by (simp add: reflp_def adds_term_refl)
moreover from assms have "p ∈ set (filter (λx. x ≠ 0) xs)" by simp
ultimately obtain q where "q ∈ set (comp_min_basis xs)" and "lt q adds⇩t lt p"
unfolding comp_min_basis_def by (rule filter_min_relE)
thus ?thesis ..
qed
lemma comp_min_basis_is_red:
assumes "is_red (set xs) f"
shows "is_red (set (comp_min_basis xs)) f"
proof -
from assms obtain x t where "x ∈ set xs" and "t ∈ keys f" and "x ≠ 0" and "lt x adds⇩t t"
by (rule is_red_addsE)
from ‹x ∈ set xs› ‹x ≠ 0› obtain y where yin: "y ∈ set (comp_min_basis xs)" and "lt y adds⇩t lt x"
by (rule comp_min_basis_adds)
show ?thesis
proof (rule is_red_addsI)
from ‹lt y adds⇩t lt x› ‹lt x adds⇩t t› show "lt y adds⇩t t" by (rule adds_term_trans)
next
from yin show "y ≠ 0" by (rule comp_min_basis_nonzero)
qed fact+
qed
lemma comp_min_basis_nadds:
assumes "p ∈ set (comp_min_basis xs)" and "q ∈ set (comp_min_basis xs)" and "p ≠ q"
shows "¬ lt q adds⇩t lt p"
proof
have "transp (λx y. lt x adds⇩t lt y)" by (auto intro!: transpI dest: adds_term_trans)
moreover note assms(2, 1)
moreover assume "lt q adds⇩t lt p"
ultimately have "q = p" unfolding comp_min_basis_def by (rule filter_min_minimal)
with assms(3) show False by simp
qed
lemma comp_min_basis_is_minimal_basis: "is_minimal_basis (set (comp_min_basis xs))"
by (rule is_minimal_basisI, rule comp_min_basis_nonzero, assumption, rule comp_min_basis_nadds,
assumption+, simp)
lemma comp_min_basis_distinct: "distinct (comp_min_basis xs)"
unfolding comp_min_basis_def by (rule filter_min_distinct) (simp add: reflp_def adds_term_refl)
end
subsection ‹Auto-Reduction›
context gd_term
begin
lemma is_minimal_basis_trd_is_minimal_basis:
assumes "is_minimal_basis (set (x # xs))" and "x ∉ set xs"
shows "is_minimal_basis (set ((trd xs x) # xs))"
proof -
from assms(1) have "is_minimal_basis (insert (trd xs x) (set (x # xs) - {x}))"
proof (rule is_minimal_basis_replace, simp)
from assms(2) have eq: "set (x # xs) - {x} = set xs" by simp
show "(red (set (x # xs) - {x}))⇧*⇧* x (trd xs x)" unfolding eq by (rule trd_red_rtrancl)
qed
also from assms(2) have "... = set ((trd xs x) # xs)" by auto
finally show ?thesis .
qed
lemma is_minimal_basis_trd_distinct:
assumes min: "is_minimal_basis (set (x # xs))" and dist: "distinct (x # xs)"
shows "distinct ((trd xs x) # xs)"
proof -
let ?y = "trd xs x"
from min have lty: "lt ?y = lt x"
proof (rule minimal_basis_red_rtrancl_lt, simp)
from dist have "x ∉ set xs" by simp
hence eq: "set (x # xs) - {x} = set xs" by simp
show "(red (set (x # xs) - {x}))⇧*⇧* x (trd xs x)" unfolding eq by (rule trd_red_rtrancl)
qed
have "?y ∉ set xs"
proof
assume "?y ∈ set xs"
hence "?y ∈ set (x # xs)" by simp
with min have "¬ lt ?y adds⇩t lt x"
proof (rule is_minimal_basisD2, simp)
show "?y ≠ x"
proof
assume "?y = x"
from dist have "x ∉ set xs" by simp
with ‹?y ∈ set xs› show False unfolding ‹?y = x› by simp
qed
qed
thus False unfolding lty by (simp add: adds_term_refl)
qed
moreover from dist have "distinct xs" by simp
ultimately show ?thesis by simp
qed
primrec comp_red_basis_aux :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list" where
comp_red_basis_aux_base: "comp_red_basis_aux Nil ys = ys"|
comp_red_basis_aux_rec: "comp_red_basis_aux (x # xs) ys = comp_red_basis_aux xs ((trd (xs @ ys) x) # ys)"
lemma subset_comp_red_basis_aux: "set ys ⊆ set (comp_red_basis_aux xs ys)"
proof (induct xs arbitrary: ys)
case Nil
show ?case unfolding comp_red_basis_aux_base ..
next
case (Cons a xs)
have "set ys ⊆ set ((trd (xs @ ys) a) # ys)" by auto
also have "... ⊆ set (comp_red_basis_aux xs ((trd (xs @ ys) a) # ys))" by (rule Cons.hyps)
finally show ?case unfolding comp_red_basis_aux_rec .
qed
lemma comp_red_basis_aux_nonzero:
assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)" and "p ∈ set (comp_red_basis_aux xs ys)"
shows "p ≠ 0"
using assms
proof (induct xs arbitrary: ys)
case Nil
show ?case
proof (rule is_minimal_basisD1)
from Nil(1) show "is_minimal_basis (set ys)" by simp
next
from Nil(3) show "p ∈ set ys" unfolding comp_red_basis_aux_base .
qed
next
case (Cons a xs)
have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp
have "a ∈ set (a # xs @ ys)" by simp
from Cons(3) have "a ∉ set (xs @ ys)" unfolding eq by simp
let ?ys = "trd (xs @ ys) a # ys"
show ?case
proof (rule Cons.hyps)
from Cons(3) have "a ∉ set (xs @ ys)" unfolding eq by simp
with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq
by (rule is_minimal_basis_trd_is_minimal_basis)
next
from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq
by (rule is_minimal_basis_trd_distinct)
next
from Cons(4) show "p ∈ set (comp_red_basis_aux xs ?ys)" unfolding comp_red_basis_aux_rec .
qed
qed
lemma comp_red_basis_aux_lt:
assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)"
shows "lt ` set (xs @ ys) = lt ` set (comp_red_basis_aux xs ys)"
using assms
proof (induct xs arbitrary: ys)
case Nil
show ?case unfolding comp_red_basis_aux_base by simp
next
case (Cons a xs)
have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp
from Cons(3) have a: "a ∉ set (xs @ ys)" unfolding eq by simp
let ?b = "trd (xs @ ys) a"
let ?ys = "?b # ys"
from Cons(2) have "lt ?b = lt a" unfolding eq
proof (rule minimal_basis_red_rtrancl_lt, simp)
from a have eq2: "set (a # xs @ ys) - {a} = set (xs @ ys)" by simp
show "(red (set (a # xs @ ys) - {a}))⇧*⇧* a ?b" unfolding eq2 by (rule trd_red_rtrancl)
qed
hence "lt ` set ((a # xs) @ ys) = lt ` set ((?b # xs) @ ys)" by simp
also have "... = lt ` set (xs @ (?b # ys))" by simp
finally have eq2: "lt ` set ((a # xs) @ ys) = lt ` set (xs @ (?b # ys))" .
show ?case unfolding comp_red_basis_aux_rec eq2
proof (rule Cons.hyps)
from Cons(3) have "a ∉ set (xs @ ys)" unfolding eq by simp
with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq
by (rule is_minimal_basis_trd_is_minimal_basis)
next
from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq
by (rule is_minimal_basis_trd_distinct)
qed
qed
lemma comp_red_basis_aux_pmdl:
assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)"
shows "pmdl (set (comp_red_basis_aux xs ys)) ⊆ pmdl (set (xs @ ys))"
using assms
proof (induct xs arbitrary: ys)
case Nil
show ?case unfolding comp_red_basis_aux_base by simp
next
case (Cons a xs)
have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp
from Cons(3) have a: "a ∉ set (xs @ ys)" unfolding eq by simp
let ?b = "trd (xs @ ys) a"
let ?ys = "?b # ys"
have "pmdl (set (comp_red_basis_aux xs ?ys)) ⊆ pmdl (set (xs @ ?ys))"
proof (rule Cons.hyps)
from Cons(3) have "a ∉ set (xs @ ys)" unfolding eq by simp
with Cons(2) show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq
by (rule is_minimal_basis_trd_is_minimal_basis)
next
from Cons(2) Cons(3) show "distinct (xs @ ?ys)" unfolding distinct_reorder eq
by (rule is_minimal_basis_trd_distinct)
qed
also have "... = pmdl (set (?b # xs @ ys))" by simp
also from a have "... = pmdl (insert ?b (set (a # xs @ ys) - {a}))" by auto
also have "... ⊆ pmdl (set (a # xs @ ys))"
proof (rule pmdl.replace_span)
have "a - (trd (xs @ ys) a) ∈ pmdl (set (xs @ ys))" by (rule trd_in_pmdl)
have "a - (trd (xs @ ys) a) ∈ pmdl (set (a # xs @ ys))"
proof
show "pmdl (set (xs @ ys)) ⊆ pmdl (set (a # xs @ ys))" by (rule pmdl.span_mono) auto
qed fact
hence "- (a - (trd (xs @ ys) a)) ∈ pmdl (set (a # xs @ ys))" by (rule pmdl.span_neg)
hence "(trd (xs @ ys) a) - a ∈ pmdl (set (a # xs @ ys))" by simp
hence "((trd (xs @ ys) a) - a) + a ∈ pmdl (set (a # xs @ ys))"
proof (rule pmdl.span_add)
show "a ∈ pmdl (set (a # xs @ ys))"
proof
show "a ∈ set (a # xs @ ys)" by simp
qed (rule pmdl.span_superset)
qed
thus "trd (xs @ ys) a ∈ pmdl (set (a # xs @ ys))" by simp
qed
also have "... = pmdl (set ((a # xs) @ ys))" by simp
finally show ?case unfolding comp_red_basis_aux_rec .
qed
lemma comp_red_basis_aux_irred:
assumes "is_minimal_basis (set (xs @ ys))" and "distinct (xs @ ys)"
and "⋀y. y ∈ set ys ⟹ ¬ is_red (set (xs @ ys) - {y}) y"
and "p ∈ set (comp_red_basis_aux xs ys)"
shows "¬ is_red (set (comp_red_basis_aux xs ys) - {p}) p"
using assms
proof (induct xs arbitrary: ys)
case Nil
have "¬ is_red (set ([] @ ys) - {p}) p"
proof (rule Nil(3))
from Nil(4) show "p ∈ set ys" unfolding comp_red_basis_aux_base .
qed
thus ?case unfolding comp_red_basis_aux_base by simp
next
case (Cons a xs)
have eq: "(a # xs) @ ys = a # (xs @ ys)" by simp
from Cons(3) have a_notin: "a ∉ set (xs @ ys)" unfolding eq by simp
from Cons(2) have is_min: "is_minimal_basis (set (a # xs @ ys))" unfolding eq .
let ?b = "trd (xs @ ys) a"
let ?ys = "?b # ys"
have dist: "distinct (?b # (xs @ ys))"
proof (rule is_minimal_basis_trd_distinct, fact is_min)
from Cons(3) show "distinct (a # xs @ ys)" unfolding eq .
qed
show ?case unfolding comp_red_basis_aux_rec
proof (rule Cons.hyps)
from Cons(2) a_notin show "is_minimal_basis (set (xs @ ?ys))" unfolding set_reorder eq
by (rule is_minimal_basis_trd_is_minimal_basis)
next
from dist show "distinct (xs @ ?ys)" unfolding distinct_reorder .
next
fix y
assume "y ∈ set ?ys"
hence "y = ?b ∨ y ∈ set ys" by simp
thus "¬ is_red (set (xs @ ?ys) - {y}) y"
proof
assume "y = ?b"
from dist have "?b ∉ set (xs @ ys)" by simp
hence eq3: "set (xs @ ?ys) - {?b} = set (xs @ ys)" unfolding set_reorder by simp
have "¬ is_red (set (xs @ ys)) ?b" by (rule trd_irred)
thus ?thesis unfolding ‹y = ?b› eq3 .
next
assume "y ∈ set ys"
hence irred: "¬ is_red (set ((a # xs) @ ys) - {y}) y" by (rule Cons(4))
from ‹y ∈ set ys› a_notin have "y ≠ a" by auto
hence eq3: "set ((a # xs) @ ys) - {y} = {a} ∪ (set (xs @ ys) - {y})" by auto
from irred have i1: "¬ is_red {a} y" and i2: "¬ is_red (set (xs @ ys) - {y}) y"
unfolding eq3 is_red_union by simp_all
show ?thesis unfolding set_reorder
proof (cases "y = ?b")
case True
from i2 show "¬ is_red (set (?b # xs @ ys) - {y}) y" by (simp add: True)
next
case False
hence eq4: "set (?b # xs @ ys) - {y} = {?b} ∪ (set (xs @ ys) - {y})" by auto
show "¬ is_red (set (?b # xs @ ys) - {y}) y" unfolding eq4
proof
assume "is_red ({?b} ∪ (set (xs @ ys) - {y})) y"
thus False unfolding is_red_union
proof
have ltb: "lt ?b = lt a"
proof (rule minimal_basis_red_rtrancl_lt, fact is_min)
show "a ∈ set (a # xs @ ys)" by simp
next
from a_notin have eq: "set (a # xs @ ys) - {a} = set (xs @ ys)" by simp
show "(red (set (a # xs @ ys) - {a}))⇧*⇧* a ?b" unfolding eq by (rule trd_red_rtrancl)
qed
assume "is_red {?b} y"
then obtain t where "t ∈ keys y" and "lt ?b adds⇩t t" unfolding is_red_adds_iff by auto
with ltb have "lt a adds⇩t t" by simp
have "is_red {a} y"
by (rule is_red_addsI, rule, rule is_minimal_basisD1, fact is_min, simp, fact+)
with i1 show False ..
next
assume "is_red (set (xs @ ys) - {y}) y"
with i2 show False ..
qed
qed
qed
qed
next
from Cons(5) show "p ∈ set (comp_red_basis_aux xs ?ys)" unfolding comp_red_basis_aux_rec .
qed
qed
lemma comp_red_basis_aux_dgrad_p_set_le:
assumes "dickson_grading d"
shows "dgrad_p_set_le d (set (comp_red_basis_aux xs ys)) (set xs ∪ set ys)"
proof (induct xs arbitrary: ys)
case Nil
show ?case by (simp, rule dgrad_p_set_le_subset, fact subset_refl)
next
case (Cons x xs)
let ?h = "trd (xs @ ys) x"
have "dgrad_p_set_le d (set (comp_red_basis_aux xs (?h # ys))) (set xs ∪ set (?h # ys))"
by (fact Cons)
also have "... = insert ?h (set xs ∪ set ys)" by simp
also have "dgrad_p_set_le d ... (insert x (set xs ∪ set ys))"
proof (rule dgrad_p_set_leI_insert)
show "dgrad_p_set_le d (set xs ∪ set ys) (insert x (set xs ∪ set ys))"
by (rule dgrad_p_set_le_subset, blast)
next
have "(red (set (xs @ ys)))⇧*⇧* x ?h" by (rule trd_red_rtrancl)
with assms have "dgrad_p_set_le d {?h} (insert x (set (xs @ ys)))"
by (rule dgrad_p_set_le_red_rtrancl)
thus "dgrad_p_set_le d {?h} (insert x (set xs ∪ set ys))" by simp
qed
finally show ?case by simp
qed
definition comp_red_basis :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list"
where "comp_red_basis xs = comp_red_basis_aux (comp_min_basis xs) []"
lemma comp_red_basis_nonzero:
assumes "p ∈ set (comp_red_basis xs)"
shows "p ≠ 0"
proof -
have "is_minimal_basis (set ((comp_min_basis xs) @ []))" by (simp add: comp_min_basis_is_minimal_basis)
moreover have "distinct ((comp_min_basis xs) @ [])" by (simp add: comp_min_basis_distinct)
moreover from assms have "p ∈ set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def .
ultimately show ?thesis by (rule comp_red_basis_aux_nonzero)
qed
lemma pmdl_comp_red_basis_subset: "pmdl (set (comp_red_basis xs)) ⊆ pmdl (set xs)"
proof
fix f
assume fin: "f ∈ pmdl (set (comp_red_basis xs))"
have "f ∈ pmdl (set (comp_min_basis xs))"
proof
from fin show "f ∈ pmdl (set (comp_red_basis_aux (comp_min_basis xs) []))"
unfolding comp_red_basis_def .
next
have "pmdl (set (comp_red_basis_aux (comp_min_basis xs) [])) ⊆ pmdl (set ((comp_min_basis xs) @ []))"
by (rule comp_red_basis_aux_pmdl, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct)
thus "pmdl (set (comp_red_basis_aux (comp_min_basis xs) [])) ⊆ pmdl (set (comp_min_basis xs))"
by simp
qed
also from comp_min_basis_subset have "... ⊆ pmdl (set xs)" by (rule pmdl.span_mono)
finally show "f ∈ pmdl (set xs)" .
qed
lemma comp_red_basis_adds:
assumes "p ∈ set xs" and "p ≠ 0"
obtains q where "q ∈ set (comp_red_basis xs)" and "lt q adds⇩t lt p"
proof -
from assms obtain q1 where "q1 ∈ set (comp_min_basis xs)" and "lt q1 adds⇩t lt p"
by (rule comp_min_basis_adds)
from ‹q1 ∈ set (comp_min_basis xs)› have "lt q1 ∈ lt ` set (comp_min_basis xs)" by simp
also have "... = lt ` set ((comp_min_basis xs) @ [])" by simp
also have "... = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])"
by (rule comp_red_basis_aux_lt, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct)
finally obtain q where "q ∈ set (comp_red_basis_aux (comp_min_basis xs) [])" and "lt q = lt q1"
by auto
show ?thesis
proof
show "q ∈ set (comp_red_basis xs)" unfolding comp_red_basis_def by fact
next
from ‹lt q1 adds⇩t lt p› show "lt q adds⇩t lt p" unfolding ‹lt q = lt q1› .
qed
qed
lemma comp_red_basis_lt:
assumes "p ∈ set (comp_red_basis xs)"
obtains q where "q ∈ set xs" and "q ≠ 0" and "lt q = lt p"
proof -
have eq: "lt ` set ((comp_min_basis xs) @ []) = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])"
by (rule comp_red_basis_aux_lt, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct)
from assms have "lt p ∈ lt ` set (comp_red_basis xs)" by simp
also have "... = lt ` set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def ..
also have "... = lt ` set (comp_min_basis xs)" unfolding eq[symmetric] by simp
finally obtain q where "q ∈ set (comp_min_basis xs)" and "lt q = lt p" by auto
show ?thesis
proof
show "q ∈ set xs" by (rule, fact, rule comp_min_basis_subset)
next
show "q ≠ 0" by (rule comp_min_basis_nonzero, fact)
qed fact
qed
lemma comp_red_basis_is_red: "is_red (set (comp_red_basis xs)) f ⟷ is_red (set xs) f"
proof
assume "is_red (set (comp_red_basis xs)) f"
then obtain x t where "x ∈ set (comp_red_basis xs)" and "t ∈ keys f" and "x ≠ 0" and "lt x adds⇩t t"
by (rule is_red_addsE)
from ‹x ∈ set (comp_red_basis xs)› obtain y where yin: "y ∈ set xs" and "y ≠ 0" and "lt y = lt x"
by (rule comp_red_basis_lt)
show "is_red (set xs) f"
proof (rule is_red_addsI)
from ‹lt x adds⇩t t› show "lt y adds⇩t t" unfolding ‹lt y = lt x› .
qed fact+
next
assume "is_red (set xs) f"
then obtain x t where "x ∈ set xs" and "t ∈ keys f" and "x ≠ 0" and "lt x adds⇩t t"
by (rule is_red_addsE)
from ‹x ∈ set xs› ‹x ≠ 0› obtain y where yin: "y ∈ set (comp_red_basis xs)" and "lt y adds⇩t lt x"
by (rule comp_red_basis_adds)
show "is_red (set (comp_red_basis xs)) f"
proof (rule is_red_addsI)
from ‹lt y adds⇩t lt x› ‹lt x adds⇩t t› show "lt y adds⇩t t" by (rule adds_term_trans)
next
from yin show "y ≠ 0" by (rule comp_red_basis_nonzero)
qed fact+
qed
lemma comp_red_basis_is_auto_reduced: "is_auto_reduced (set (comp_red_basis xs))"
unfolding is_auto_reduced_def remove_def
proof (intro ballI)
fix x
assume xin: "x ∈ set (comp_red_basis xs)"
show "¬ is_red (set (comp_red_basis xs) - {x}) x" unfolding comp_red_basis_def
proof (rule comp_red_basis_aux_irred, simp_all, rule comp_min_basis_is_minimal_basis, rule comp_min_basis_distinct)
from xin show "x ∈ set (comp_red_basis_aux (comp_min_basis xs) [])" unfolding comp_red_basis_def .
qed
qed
lemma comp_red_basis_dgrad_p_set_le:
assumes "dickson_grading d"
shows "dgrad_p_set_le d (set (comp_red_basis xs)) (set xs)"
proof -
have "dgrad_p_set_le d (set (comp_red_basis xs)) (set (comp_min_basis xs) ∪ set [])"
unfolding comp_red_basis_def using assms by (rule comp_red_basis_aux_dgrad_p_set_le)
also have "... = set (comp_min_basis xs)" by simp
also from comp_min_basis_subset have "dgrad_p_set_le d ... (set xs)"
by (rule dgrad_p_set_le_subset)
finally show ?thesis .
qed
subsection ‹Auto-Reduction and Monicity›
definition comp_red_monic_basis :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list" where
"comp_red_monic_basis xs = map monic (comp_red_basis xs)"
lemma set_comp_red_monic_basis: "set (comp_red_monic_basis xs) = monic ` (set (comp_red_basis xs))"
by (simp add: comp_red_monic_basis_def)
lemma comp_red_monic_basis_nonzero:
assumes "p ∈ set (comp_red_monic_basis xs)"
shows "p ≠ 0"
proof -
from assms obtain p' where p_def: "p = monic p'" and p': "p' ∈ set (comp_red_basis xs)"
unfolding set_comp_red_monic_basis ..
from p' have "p' ≠ 0" by (rule comp_red_basis_nonzero)
thus ?thesis unfolding p_def monic_0_iff .
qed
lemma comp_red_monic_basis_is_monic_set: "is_monic_set (set (comp_red_monic_basis xs))"
unfolding set_comp_red_monic_basis by (rule image_monic_is_monic_set)
lemma pmdl_comp_red_monic_basis_subset: "pmdl (set (comp_red_monic_basis xs)) ⊆ pmdl (set xs)"
unfolding set_comp_red_monic_basis pmdl_image_monic by (fact pmdl_comp_red_basis_subset)
lemma comp_red_monic_basis_is_auto_reduced: "is_auto_reduced (set (comp_red_monic_basis xs))"
unfolding set_comp_red_monic_basis by (rule image_monic_is_auto_reduced, rule comp_red_basis_is_auto_reduced)
lemma comp_red_monic_basis_dgrad_p_set_le:
assumes "dickson_grading d"
shows "dgrad_p_set_le d (set (comp_red_monic_basis xs)) (set xs)"
proof -
have "dgrad_p_set_le d (monic ` (set (comp_red_basis xs))) (set (comp_red_basis xs))"
by (simp add: dgrad_p_set_le_def, fact dgrad_set_le_refl)
also from assms have "dgrad_p_set_le d ... (set xs)" by (rule comp_red_basis_dgrad_p_set_le)
finally show ?thesis by (simp add: set_comp_red_monic_basis)
qed
end
end
Theory Reduced_GB
section ‹Reduced Gr\"obner Bases›
theory Reduced_GB
imports Groebner_Bases Auto_Reduction
begin
lemma (in gd_term) GB_image_monic: "is_Groebner_basis (monic ` G) ⟷ is_Groebner_basis G"
by (simp add: GB_alt_1)
subsection ‹Definition and Uniqueness of Reduced Gr\"obner Bases›
context ordered_term
begin
definition is_reduced_GB :: "('t ⇒⇩0 'b::field) set ⇒ bool" where
"is_reduced_GB B ≡ is_Groebner_basis B ∧ is_auto_reduced B ∧ is_monic_set B ∧ 0 ∉ B"
lemma reduced_GB_D1:
assumes "is_reduced_GB G"
shows "is_Groebner_basis G"
using assms unfolding is_reduced_GB_def by simp
lemma reduced_GB_D2:
assumes "is_reduced_GB G"
shows "is_auto_reduced G"
using assms unfolding is_reduced_GB_def by simp
lemma reduced_GB_D3:
assumes "is_reduced_GB G"
shows "is_monic_set G"
using assms unfolding is_reduced_GB_def by simp
lemma reduced_GB_D4:
assumes "is_reduced_GB G" and "g ∈ G"
shows "g ≠ 0"
using assms unfolding is_reduced_GB_def by auto
lemma reduced_GB_lc:
assumes major: "is_reduced_GB G" and "g ∈ G"
shows "lc g = 1"
by (rule is_monic_setD, rule reduced_GB_D3, fact major, fact ‹g ∈ G›, rule reduced_GB_D4, fact major, fact ‹g ∈ G›)
end
context gd_term
begin
lemma is_reduced_GB_subsetI:
assumes Ared: "is_reduced_GB A" and BGB: "is_Groebner_basis B" and Bmon: "is_monic_set B"
and *: "⋀a b. a ∈ A ⟹ b ∈ B ⟹ a ≠ 0 ⟹ b ≠ 0 ⟹ a - b ≠ 0 ⟹ lt (a - b) ∈ keys b ⟹ lt (a - b) ≺⇩t lt b ⟹ False"
and id_eq: "pmdl A = pmdl B"
shows "A ⊆ B"
proof
fix a
assume "a ∈ A"
have "a ≠ 0" by (rule reduced_GB_D4, fact Ared, fact ‹a ∈ A›)
have lca: "lc a = 1" by (rule reduced_GB_lc, fact Ared, fact ‹a ∈ A›)
have AGB: "is_Groebner_basis A" by (rule reduced_GB_D1, fact Ared)
from ‹a ∈ A› have "a ∈ pmdl A" by (rule pmdl.span_base)
also have "... = pmdl B" using id_eq by simp
finally have "a ∈ pmdl B" .
from BGB this ‹a ≠ 0› obtain b where "b ∈ B" and "b ≠ 0" and baddsa: "lt b adds⇩t lt a"
by (rule GB_adds_lt)
from Bmon this(1) this(2) have lcb: "lc b = 1" by (rule is_monic_setD)
from ‹b ∈ B› have "b ∈ pmdl B" by (rule pmdl.span_base)
also have "... = pmdl A" using id_eq by simp
finally have "b ∈ pmdl A" .
have lt_eq: "lt b = lt a"
proof (rule ccontr)
assume "lt b ≠ lt a"
from AGB ‹b ∈ pmdl A› ‹b ≠ 0› obtain a'
where "a' ∈ A" and "a' ≠ 0" and a'addsb: "lt a' adds⇩t lt b" by (rule GB_adds_lt)
have a'addsa: "lt a' adds⇩t lt a" by (rule adds_term_trans, fact a'addsb, fact baddsa)
have "lt a' ≠ lt a"
proof
assume "lt a' = lt a"
hence aaddsa': "lt a adds⇩t lt a'" by (simp add: adds_term_refl)
have "lt a adds⇩t lt b" by (rule adds_term_trans, fact aaddsa', fact a'addsb)
have "lt a = lt b" by (rule adds_term_antisym, fact+)
with ‹lt b ≠ lt a› show False by simp
qed
hence "a' ≠ a" by auto
with ‹a' ∈ A› have "a' ∈ A - {a}" by blast
have is_red: "is_red (A - {a}) a" by (intro is_red_addsI, fact, fact, rule lt_in_keys, fact+)
have "¬ is_red (A - {a}) a" by (rule is_auto_reducedD, rule reduced_GB_D2, fact Ared, fact+)
from this is_red show False ..
qed
have "a - b = 0"
proof (rule ccontr)
let ?c = "a - b"
assume "?c ≠ 0"
have "?c ∈ pmdl A" by (rule pmdl.span_diff, fact+)
also have "... = pmdl B" using id_eq by simp
finally have "?c ∈ pmdl B" .
from ‹b ≠ 0› have "- b ≠ 0" by simp
have "lt (-b) = lt a" unfolding lt_uminus by fact
have "lc (-b) = - lc a" unfolding lc_uminus lca lcb ..
from ‹?c ≠ 0› have "a + (-b) ≠ 0" by simp
have "lt ?c ∈ keys ?c" by (rule lt_in_keys, fact)
have "keys ?c ⊆ (keys a ∪ keys b)" by (fact keys_minus)
with ‹lt ?c ∈ keys ?c› have "lt ?c ∈ keys a ∨ lt ?c ∈ keys b" by auto
thus False
proof
assume "lt ?c ∈ keys a"
from AGB ‹?c ∈ pmdl A› ‹?c ≠ 0› obtain a'
where "a' ∈ A" and "a' ≠ 0" and a'addsc: "lt a' adds⇩t lt ?c" by (rule GB_adds_lt)
from a'addsc have "lt a' ≼⇩t lt ?c" by (rule ord_adds_term)
also have "... = lt (a + (- b))" by simp
also have "... ≺⇩t lt a" by (rule lt_plus_lessI, fact+)
finally have "lt a' ≺⇩t lt a" .
hence "lt a' ≠ lt a" by simp
hence "a' ≠ a" by auto
with ‹a' ∈ A› have "a' ∈ A - {a}" by blast
have is_red: "is_red (A - {a}) a" by (intro is_red_addsI, fact, fact, fact+)
have "¬ is_red (A - {a}) a" by (rule is_auto_reducedD, rule reduced_GB_D2, fact Ared, fact+)
from this is_red show False ..
next
assume "lt ?c ∈ keys b"
with ‹a ∈ A› ‹b ∈ B› ‹a ≠ 0› ‹b ≠ 0› ‹?c ≠ 0› show False
proof (rule *)
have "lt ?c = lt ((- b) + a)" by simp
also have "... ≺⇩t lt (-b)"
proof (rule lt_plus_lessI)
from ‹?c ≠ 0› show "-b + a ≠ 0" by simp
next
from ‹lt (-b) = lt a› show "lt a = lt (-b)" by simp
next
from ‹lc (-b) = - lc a› show "lc a = - lc (-b)" by simp
qed
finally show "lt ?c ≺⇩t lt b" unfolding lt_uminus .
qed
qed
qed
hence "a = b" by simp
with ‹b ∈ B› show "a ∈ B" by simp
qed
lemma is_reduced_GB_unique':
assumes Ared: "is_reduced_GB A" and Bred: "is_reduced_GB B" and id_eq: "pmdl A = pmdl B"
shows "A ⊆ B"
proof -
from Bred have BGB: "is_Groebner_basis B" by (rule reduced_GB_D1)
with assms(1) show ?thesis
proof (rule is_reduced_GB_subsetI)
from Bred show "is_monic_set B" by (rule reduced_GB_D3)
next
fix a b :: "'t ⇒⇩0 'b"
let ?c = "a - b"
assume "a ∈ A" and "b ∈ B" and "a ≠ 0" and "b ≠ 0" and "?c ≠ 0" and "lt ?c ∈ keys b" and "lt ?c ≺⇩t lt b"
from ‹a ∈ A› have "a ∈ pmdl B" by (simp only: id_eq[symmetric], rule pmdl.span_base)
moreover from ‹b ∈ B› have "b ∈ pmdl B" by (rule pmdl.span_base)
ultimately have "?c ∈ pmdl B" by (rule pmdl.span_diff)
from BGB this ‹?c ≠ 0› obtain b'
where "b' ∈ B" and "b' ≠ 0" and b'addsc: "lt b' adds⇩t lt ?c" by (rule GB_adds_lt)
from b'addsc have "lt b' ≼⇩t lt ?c" by (rule ord_adds_term)
also have "... ≺⇩t lt b" by fact
finally have "lt b' ≺⇩t lt b" unfolding lt_uminus .
hence "lt b' ≠ lt b" by simp
hence "b' ≠ b" by auto
with ‹b' ∈ B› have "b' ∈ B - {b}" by blast
have is_red: "is_red (B - {b}) b" by (intro is_red_addsI, fact, fact, fact+)
have "¬ is_red (B - {b}) b" by (rule is_auto_reducedD, rule reduced_GB_D2, fact Bred, fact+)
from this is_red show False ..
qed fact
qed
theorem is_reduced_GB_unique:
assumes Ared: "is_reduced_GB A" and Bred: "is_reduced_GB B" and id_eq: "pmdl A = pmdl B"
shows "A = B"
proof
from assms show "A ⊆ B" by (rule is_reduced_GB_unique')
next
from Bred Ared id_eq[symmetric] show "B ⊆ A" by (rule is_reduced_GB_unique')
qed
subsection ‹Computing Reduced Gr\"obner Bases by Auto-Reduction›
subsubsection ‹Minimal Bases›
lemma minimal_basis_is_reduced_GB:
assumes "is_minimal_basis B" and "is_monic_set B" and "is_reduced_GB G" and "G ⊆ B"
and "pmdl B = pmdl G"
shows "B = G"
using _ assms(3) assms(5)
proof (rule is_reduced_GB_unique)
from assms(3) have "is_Groebner_basis G" by (rule reduced_GB_D1)
show "is_reduced_GB B" unfolding is_reduced_GB_def
proof (intro conjI)
show "0 ∉ B"
proof
assume "0 ∈ B"
with assms(1) have "0 ≠ (0::'t ⇒⇩0 'b)" by (rule is_minimal_basisD1)
thus False by simp
qed
next
from ‹is_Groebner_basis G› assms(4) assms(5) show "is_Groebner_basis B" by (rule GB_subset)
next
show "is_auto_reduced B" unfolding is_auto_reduced_def
proof (intro ballI notI)
fix b
assume "b ∈ B"
with assms(1) have "b ≠ 0" by (rule is_minimal_basisD1)
assume "is_red (B - {b}) b"
then obtain f where "f ∈ B - {b}" and "is_red {f} b" by (rule is_red_singletonI)
from this(1) have "f ∈ B" and "f ≠ b" by simp_all
from assms(1) ‹f ∈ B› have "f ≠ 0" by (rule is_minimal_basisD1)
from ‹f ∈ B› have "f ∈ pmdl B" by (rule pmdl.span_base)
hence "f ∈ pmdl G" by (simp only: assms(5))
from ‹is_Groebner_basis G› this ‹f ≠ 0› obtain g where "g ∈ G" and "g ≠ 0" and "lt g adds⇩t lt f"
by (rule GB_adds_lt)
from ‹g ∈ G› ‹G ⊆ B› have "g ∈ B" ..
have "g = f"
proof (rule ccontr)
assume "g ≠ f"
with assms(1) ‹g ∈ B› ‹f ∈ B› have "¬ lt g adds⇩t lt f" by (rule is_minimal_basisD2)
from this ‹lt g adds⇩t lt f› show False ..
qed
with ‹g ∈ G› have "f ∈ G" by simp
with ‹f ∈ B - {b}› ‹is_red {f} b› have red: "is_red (G - {b}) b"
by (meson Diff_iff is_red_singletonD)
from ‹b ∈ B› have "b ∈ pmdl B" by (rule pmdl.span_base)
hence "b ∈ pmdl G" by (simp only: assms(5))
from ‹is_Groebner_basis G› this ‹b ≠ 0› obtain g' where "g' ∈ G" and "g' ≠ 0" and "lt g' adds⇩t lt b"
by (rule GB_adds_lt)
from ‹g' ∈ G› ‹G ⊆ B› have "g' ∈ B" ..
have "g' = b"
proof (rule ccontr)
assume "g' ≠ b"
with assms(1) ‹g' ∈ B› ‹b ∈ B› have "¬ lt g' adds⇩t lt b" by (rule is_minimal_basisD2)
from this ‹lt g' adds⇩t lt b› show False ..
qed
with ‹g' ∈ G› have "b ∈ G" by simp
from assms(3) have "is_auto_reduced G" by (rule reduced_GB_D2)
from this ‹b ∈ G› have "¬ is_red (G - {b}) b" by (rule is_auto_reducedD)
from this red show False ..
qed
qed fact
qed
subsubsection ‹Computing Minimal Bases›
lemma comp_min_basis_pmdl:
assumes "is_Groebner_basis (set xs)"
shows "pmdl (set (comp_min_basis xs)) = pmdl (set xs)" (is "pmdl (set ?ys) = _")
using finite_set
proof (rule pmdl_eqI_adds_lt_finite)
from comp_min_basis_subset show *: "pmdl (set ?ys) ⊆ pmdl (set xs)" by (rule pmdl.span_mono)
next
fix f
assume "f ∈ pmdl (set xs)" and "f ≠ 0"
with assms obtain g where "g ∈ set xs" and "g ≠ 0" and 1: "lt g adds⇩t lt f" by (rule GB_adds_lt)
from this(1, 2) obtain g' where "g' ∈ set ?ys" and 2: "lt g' adds⇩t lt g"
by (rule comp_min_basis_adds)
note this(1)
moreover from this have "g' ≠ 0" by (rule comp_min_basis_nonzero)
moreover from 2 1 have "lt g' adds⇩t lt f" by (rule adds_term_trans)
ultimately show "∃g∈set ?ys. g ≠ 0 ∧ lt g adds⇩t lt f" by blast
qed
lemma comp_min_basis_GB:
assumes "is_Groebner_basis (set xs)"
shows "is_Groebner_basis (set (comp_min_basis xs))" (is "is_Groebner_basis (set ?ys)")
unfolding GB_alt_2_finite[OF finite_set]
proof (intro ballI impI)
fix f
assume "f ∈ pmdl (set ?ys)"
also from assms have "… = pmdl (set xs)" by (rule comp_min_basis_pmdl)
finally have "f ∈ pmdl (set xs)" .
moreover assume "f ≠ 0"
ultimately have "is_red (set xs) f" using assms unfolding GB_alt_2_finite[OF finite_set] by blast
thus "is_red (set ?ys) f" by (rule comp_min_basis_is_red)
qed
subsubsection ‹Computing Reduced Bases›
lemma comp_red_basis_pmdl:
assumes "is_Groebner_basis (set xs)"
shows "pmdl (set (comp_red_basis xs)) = pmdl (set xs)"
proof (rule, fact pmdl_comp_red_basis_subset, rule)
fix f
assume "f ∈ pmdl (set xs)"
show "f ∈ pmdl (set (comp_red_basis xs))"
proof (cases "f = 0")
case True
show ?thesis unfolding True by (rule pmdl.span_zero)
next
case False
let ?xs = "comp_red_basis xs"
have "(red (set ?xs))⇧*⇧* f 0"
proof (rule is_red_implies_0_red_finite, fact finite_set, fact pmdl_comp_red_basis_subset)
fix q
assume "q ≠ 0" and "q ∈ pmdl (set xs)"
with assms have "is_red (set xs) q" by (rule GB_imp_reducibility)
thus "is_red (set (comp_red_basis xs)) q" unfolding comp_red_basis_is_red .
qed fact
thus ?thesis by (rule red_rtranclp_0_in_pmdl)
qed
qed
lemma comp_red_basis_GB:
assumes "is_Groebner_basis (set xs)"
shows "is_Groebner_basis (set (comp_red_basis xs))"
unfolding GB_alt_2_finite[OF finite_set]
proof (intro ballI impI)
fix f
assume fin: "f ∈ pmdl (set (comp_red_basis xs))"
hence "f ∈ pmdl (set xs)" unfolding comp_red_basis_pmdl[OF assms] .
assume "f ≠ 0"
from assms ‹f ≠ 0› ‹f ∈ pmdl (set xs)› show "is_red (set (comp_red_basis xs)) f"
by (simp add: comp_red_basis_is_red GB_alt_2_finite)
qed
subsubsection ‹Computing Reduced Gr\"obner Bases›
lemma comp_red_monic_basis_pmdl:
assumes "is_Groebner_basis (set xs)"
shows "pmdl (set (comp_red_monic_basis xs)) = pmdl (set xs)"
unfolding set_comp_red_monic_basis pmdl_image_monic comp_red_basis_pmdl[OF assms] ..
lemma comp_red_monic_basis_GB:
assumes "is_Groebner_basis (set xs)"
shows "is_Groebner_basis (set (comp_red_monic_basis xs))"
unfolding set_comp_red_monic_basis GB_image_monic using assms by (rule comp_red_basis_GB)
lemma comp_red_monic_basis_is_reduced_GB:
assumes "is_Groebner_basis (set xs)"
shows "is_reduced_GB (set (comp_red_monic_basis xs))"
unfolding is_reduced_GB_def
proof (intro conjI, rule comp_red_monic_basis_GB, fact assms,
rule comp_red_monic_basis_is_auto_reduced, rule comp_red_monic_basis_is_monic_set, intro notI)
assume "0 ∈ set (comp_red_monic_basis xs)"
hence "0 ≠ (0::'t ⇒⇩0 'b)" by (rule comp_red_monic_basis_nonzero)
thus False by simp
qed
lemma ex_finite_reduced_GB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
obtains G where "G ⊆ dgrad_p_set d m" and "finite G" and "is_reduced_GB G" and "pmdl G = pmdl F"
proof -
from assms obtain G0 where G0_sub: "G0 ⊆ dgrad_p_set d m" and fin: "finite G0"
and gb: "is_Groebner_basis G0" and pid: "pmdl G0 = pmdl F"
by (rule ex_finite_GB_dgrad_p_set)
from fin obtain xs where set: "G0 = set xs" using finite_list by blast
let ?G = "set (comp_red_monic_basis xs)"
show ?thesis
proof
from assms(1) have "dgrad_p_set_le d (set (comp_red_monic_basis xs)) G0" unfolding set
by (rule comp_red_monic_basis_dgrad_p_set_le)
from this G0_sub show "set (comp_red_monic_basis xs) ⊆ dgrad_p_set d m"
by (rule dgrad_p_set_le_dgrad_p_set)
next
from gb show rgb: "is_reduced_GB ?G" unfolding set
by (rule comp_red_monic_basis_is_reduced_GB)
next
from gb show "pmdl ?G = pmdl F" unfolding set pid[symmetric]
by (rule comp_red_monic_basis_pmdl)
qed (fact finite_set)
qed
theorem ex_unique_reduced_GB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "∃!G. G ⊆ dgrad_p_set d m ∧ finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F"
proof -
from assms obtain G where "G ⊆ dgrad_p_set d m" and "finite G"
and "is_reduced_GB G" and G: "pmdl G = pmdl F" by (rule ex_finite_reduced_GB_dgrad_p_set)
hence "G ⊆ dgrad_p_set d m ∧ finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F" by simp
thus ?thesis
proof (rule ex1I)
fix G'
assume "G' ⊆ dgrad_p_set d m ∧ finite G' ∧ is_reduced_GB G' ∧ pmdl G' = pmdl F"
hence "is_reduced_GB G'" and G': "pmdl G' = pmdl F" by simp_all
note this(1) ‹is_reduced_GB G›
moreover have "pmdl G' = pmdl G" by (simp only: G G')
ultimately show "G' = G" by (rule is_reduced_GB_unique)
qed
qed
corollary ex_unique_reduced_GB_dgrad_p_set':
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "∃!G. finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F"
proof -
from assms obtain G where "G ⊆ dgrad_p_set d m" and "finite G"
and "is_reduced_GB G" and G: "pmdl G = pmdl F" by (rule ex_finite_reduced_GB_dgrad_p_set)
hence "finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F" by simp
thus ?thesis
proof (rule ex1I)
fix G'
assume "finite G' ∧ is_reduced_GB G' ∧ pmdl G' = pmdl F"
hence "is_reduced_GB G'" and G': "pmdl G' = pmdl F" by simp_all
note this(1) ‹is_reduced_GB G›
moreover have "pmdl G' = pmdl G" by (simp only: G G')
ultimately show "G' = G" by (rule is_reduced_GB_unique)
qed
qed
definition reduced_GB :: "('t ⇒⇩0 'b) set ⇒ ('t ⇒⇩0 'b::field) set"
where "reduced_GB B = (THE G. finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl B)"
text ‹@{const reduced_GB} returns the unique reduced Gr\"obner basis of the given set, provided its
Dickson grading is bounded. Combining @{const comp_red_monic_basis} with any function for computing
Gr\"obner bases, e.\,g. ‹gb› from theory "Buchberger", makes @{const reduced_GB} computable.›
lemma finite_reduced_GB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "finite (reduced_GB F)"
unfolding reduced_GB_def
by (rule the1I2, rule ex_unique_reduced_GB_dgrad_p_set', fact, fact, fact, elim conjE)
lemma reduced_GB_is_reduced_GB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "is_reduced_GB (reduced_GB F)"
unfolding reduced_GB_def
by (rule the1I2, rule ex_unique_reduced_GB_dgrad_p_set', fact, fact, fact, elim conjE)
lemma reduced_GB_is_GB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "is_Groebner_basis (reduced_GB F)"
proof -
from assms have "is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set)
thus ?thesis unfolding is_reduced_GB_def ..
qed
lemma reduced_GB_is_auto_reduced_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "is_auto_reduced (reduced_GB F)"
proof -
from assms have "is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set)
thus ?thesis unfolding is_reduced_GB_def by simp
qed
lemma reduced_GB_is_monic_set_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "is_monic_set (reduced_GB F)"
proof -
from assms have "is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set)
thus ?thesis unfolding is_reduced_GB_def by simp
qed
lemma reduced_GB_nonzero_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "0 ∉ reduced_GB F"
proof -
from assms have "is_reduced_GB (reduced_GB F)" by (rule reduced_GB_is_reduced_GB_dgrad_p_set)
thus ?thesis unfolding is_reduced_GB_def by simp
qed
lemma reduced_GB_pmdl_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "pmdl (reduced_GB F) = pmdl F"
unfolding reduced_GB_def
by (rule the1I2, rule ex_unique_reduced_GB_dgrad_p_set', fact, fact, fact, elim conjE)
lemma reduced_GB_unique_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
and "is_reduced_GB G" and "pmdl G = pmdl F"
shows "reduced_GB F = G"
by (rule is_reduced_GB_unique, rule reduced_GB_is_reduced_GB_dgrad_p_set, fact+,
simp only: reduced_GB_pmdl_dgrad_p_set[OF assms(1, 2, 3)] assms(5))
lemma reduced_GB_dgrad_p_set:
assumes "dickson_grading d" and "finite (component_of_term ` Keys F)" and "F ⊆ dgrad_p_set d m"
shows "reduced_GB F ⊆ dgrad_p_set d m"
proof -
from assms obtain G where G: "G ⊆ dgrad_p_set d m" and "is_reduced_GB G" and "pmdl G = pmdl F"
by (rule ex_finite_reduced_GB_dgrad_p_set)
from assms this(2, 3) have "reduced_GB F = G" by (rule reduced_GB_unique_dgrad_p_set)
with G show ?thesis by simp
qed
lemma reduced_GB_unique:
assumes "finite G" and "is_reduced_GB G" and "pmdl G = pmdl F"
shows "reduced_GB F = G"
proof -
from assms have "finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F" by simp
thus ?thesis unfolding reduced_GB_def
proof (rule the_equality)
fix G'
assume "finite G' ∧ is_reduced_GB G' ∧ pmdl G' = pmdl F"
hence "is_reduced_GB G'" and eq: "pmdl G' = pmdl F" by simp_all
note this(1)
moreover note assms(2)
moreover have "pmdl G' = pmdl G" by (simp only: assms(3) eq)
ultimately show "G' = G" by (rule is_reduced_GB_unique)
qed
qed
lemma is_reduced_GB_empty: "is_reduced_GB {}"
by (simp add: is_reduced_GB_def is_Groebner_basis_empty is_monic_set_def is_auto_reduced_def)
lemma is_reduced_GB_singleton: "is_reduced_GB {f} ⟷ lc f = 1"
proof
assume "is_reduced_GB {f}"
hence "is_monic_set {f}" and "f ≠ 0" by (rule reduced_GB_D3, rule reduced_GB_D4) simp
from this(1) _ this(2) show "lc f = 1" by (rule is_monic_setD) simp
next
assume "lc f = 1"
moreover from this have "f ≠ 0" by auto
ultimately show "is_reduced_GB {f}"
by (simp add: is_reduced_GB_def is_Groebner_basis_singleton is_monic_set_def is_auto_reduced_def
not_is_red_empty)
qed
lemma reduced_GB_empty: "reduced_GB {} = {}"
using finite.emptyI is_reduced_GB_empty refl by (rule reduced_GB_unique)
lemma reduced_GB_singleton: "reduced_GB {f} = (if f = 0 then {} else {monic f})"
proof (cases "f = 0")
case True
from finite.emptyI is_reduced_GB_empty have "reduced_GB {f} = {}"
by (rule reduced_GB_unique) (simp add: True flip: pmdl.span_Diff_zero[of "{0}"])
with True show ?thesis by simp
next
case False
have "reduced_GB {f} = {monic f}"
proof (rule reduced_GB_unique)
from False have "lc f ≠ 0" by (rule lc_not_0)
thus "is_reduced_GB {monic f}" by (simp add: is_reduced_GB_singleton monic_def)
next
have "pmdl {monic f} = pmdl (monic ` {f})" by simp
also have "… = pmdl {f}" by (fact pmdl_image_monic)
finally show "pmdl {monic f} = pmdl {f}" .
qed simp
with False show ?thesis by simp
qed
lemma ex_unique_reduced_GB_finite: "finite F ⟹ (∃!G. finite G ∧ is_reduced_GB G ∧ pmdl G = pmdl F)"
by (rule ex_unique_reduced_GB_dgrad_p_set', rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma finite_reduced_GB_finite: "finite F ⟹ finite (reduced_GB F)"
by (rule finite_reduced_GB_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma reduced_GB_is_reduced_GB_finite: "finite F ⟹ is_reduced_GB (reduced_GB F)"
by (rule reduced_GB_is_reduced_GB_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma reduced_GB_is_GB_finite: "finite F ⟹ is_Groebner_basis (reduced_GB F)"
by (rule reduced_GB_is_GB_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma reduced_GB_is_auto_reduced_finite: "finite F ⟹ is_auto_reduced (reduced_GB F)"
by (rule reduced_GB_is_auto_reduced_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma reduced_GB_is_monic_set_finite: "finite F ⟹ is_monic_set (reduced_GB F)"
by (rule reduced_GB_is_monic_set_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma reduced_GB_nonzero_finite: "finite F ⟹ 0 ∉ reduced_GB F"
by (rule reduced_GB_nonzero_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma reduced_GB_pmdl_finite: "finite F ⟹ pmdl (reduced_GB F) = pmdl F"
by (rule reduced_GB_pmdl_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
lemma reduced_GB_unique_finite: "finite F ⟹ is_reduced_GB G ⟹ pmdl G = pmdl F ⟹ reduced_GB F = G"
by (rule reduced_GB_unique_dgrad_p_set, rule dickson_grading_dgrad_dummy,
erule finite_imp_finite_component_Keys, erule dgrad_p_set_exhaust_expl)
end
subsubsection ‹Properties of the Reduced Gr\"obner Basis of an Ideal›
context gd_powerprod
begin
lemma ideal_eq_UNIV_iff_reduced_GB_eq_one_dgrad_p_set:
assumes "dickson_grading d" and "F ⊆ punit.dgrad_p_set d m"
shows "ideal F = UNIV ⟷ punit.reduced_GB F = {1}"
proof -
have fin: "finite (local.punit.component_of_term ` Keys F)" by simp
show ?thesis
proof
assume "ideal F = UNIV"
from assms(1) fin assms(2) show "punit.reduced_GB F = {1}"
proof (rule punit.reduced_GB_unique_dgrad_p_set)
show "punit.is_reduced_GB {1}" unfolding punit.is_reduced_GB_def
proof (intro conjI, fact punit.is_Groebner_basis_singleton)
show "punit.is_auto_reduced {1}" unfolding punit.is_auto_reduced_def
by (rule ballI, simp add: remove_def punit.not_is_red_empty)
next
show "punit.is_monic_set {1}"
by (rule punit.is_monic_setI, simp del: single_one add: single_one[symmetric])
qed simp
next
have "punit.pmdl {1} = ideal {1}" by simp
also have "... = ideal F"
proof (simp only: ‹ideal F = UNIV› ideal_eq_UNIV_iff_contains_one)
have "1 ∈ {1}" ..
with module_times show "1 ∈ ideal {1}" by (rule module.span_base)
qed
also have "... = punit.pmdl F" by simp
finally show "punit.pmdl {1} = punit.pmdl F" .
qed
next
assume "punit.reduced_GB F = {1}"
hence "1 ∈ punit.reduced_GB F" by simp
hence "1 ∈ punit.pmdl (punit.reduced_GB F)" by (rule punit.pmdl.span_base)
also from assms(1) fin assms(2) have "... = punit.pmdl F" by (rule punit.reduced_GB_pmdl_dgrad_p_set)
finally show "ideal F = UNIV" by (simp add: ideal_eq_UNIV_iff_contains_one)
qed
qed
lemmas ideal_eq_UNIV_iff_reduced_GB_eq_one_finite =
ideal_eq_UNIV_iff_reduced_GB_eq_one_dgrad_p_set[OF dickson_grading_dgrad_dummy punit.dgrad_p_set_exhaust_expl]
end
subsubsection ‹Context @{locale od_term}›
context od_term
begin
lemmas ex_unique_reduced_GB =
ex_unique_reduced_GB_dgrad_p_set'[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
lemmas finite_reduced_GB =
finite_reduced_GB_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
lemmas reduced_GB_is_reduced_GB =
reduced_GB_is_reduced_GB_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
lemmas reduced_GB_is_GB =
reduced_GB_is_GB_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
lemmas reduced_GB_is_auto_reduced =
reduced_GB_is_auto_reduced_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
lemmas reduced_GB_is_monic_set =
reduced_GB_is_monic_set_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
lemmas reduced_GB_nonzero =
reduced_GB_nonzero_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
lemmas reduced_GB_pmdl =
reduced_GB_pmdl_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
lemmas reduced_GB_unique =
reduced_GB_unique_dgrad_p_set[OF dickson_grading_zero _ subset_dgrad_p_set_zero]
end
end
Theory Reduced_GB_Examples
section ‹Sample Computations of Reduced Gr\"obner Bases›
theory Reduced_GB_Examples
imports Buchberger Reduced_GB Polynomials.MPoly_Type_Class_OAlist Code_Target_Rat
begin
context gd_term
begin
definition rgb :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list"
where "rgb bs = comp_red_monic_basis (map fst (gb (map (λb. (b, ())) bs) ()))"
definition rgb_punit :: "('a ⇒⇩0 'b) list ⇒ ('a ⇒⇩0 'b::field) list"
where "rgb_punit bs = punit.comp_red_monic_basis (map fst (gb_punit (map (λb. (b, ())) bs) ()))"
lemma compute_trd_aux [code]:
"trd_aux fs p r =
(if is_zero p then
r
else
case find_adds fs (lt p) of
None ⇒ trd_aux fs (tail p) (plus_monomial_less r (lc p) (lt p))
| Some f ⇒ trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r
)"
by (simp only: trd_aux.simps[of fs p r] plus_monomial_less_def is_zero_def)
end
text ‹We only consider scalar polynomials here, but vector-polynomials could be handled, too.›
global_interpretation punit': gd_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term"
rewrites "punit.adds_term = (adds)"
and "punit.pp_of_term = (λx. x)"
and "punit.component_of_term = (λ_. ())"
and "punit.monom_mult = monom_mult_punit"
and "punit.mult_scalar = mult_scalar_punit"
and "punit'.punit.min_term = min_term_punit"
and "punit'.punit.lt = lt_punit cmp_term"
and "punit'.punit.lc = lc_punit cmp_term"
and "punit'.punit.tail = tail_punit cmp_term"
and "punit'.punit.ord_p = ord_p_punit cmp_term"
and "punit'.punit.ord_strict_p = ord_strict_p_punit cmp_term"
for cmp_term :: "('a::nat, 'b::{nat,add_wellorder}) pp nat_term_order"
defines find_adds_punit = punit'.punit.find_adds
and trd_aux_punit = punit'.punit.trd_aux
and trd_punit = punit'.punit.trd
and spoly_punit = punit'.punit.spoly
and count_const_lt_components_punit = punit'.punit.count_const_lt_components
and count_rem_components_punit = punit'.punit.count_rem_components
and const_lt_component_punit = punit'.punit.const_lt_component
and full_gb_punit = punit'.punit.full_gb
and add_pairs_single_sorted_punit = punit'.punit.add_pairs_single_sorted
and add_pairs_punit = punit'.punit.add_pairs
and canon_pair_order_aux_punit = punit'.punit.canon_pair_order_aux
and canon_basis_order_punit = punit'.punit.canon_basis_order
and new_pairs_sorted_punit = punit'.punit.new_pairs_sorted
and product_crit_punit = punit'.punit.product_crit
and chain_ncrit_punit = punit'.punit.chain_ncrit
and chain_ocrit_punit = punit'.punit.chain_ocrit
and apply_icrit_punit = punit'.punit.apply_icrit
and apply_ncrit_punit = punit'.punit.apply_ncrit
and apply_ocrit_punit = punit'.punit.apply_ocrit
and trdsp_punit = punit'.punit.trdsp
and gb_sel_punit = punit'.punit.gb_sel
and gb_red_aux_punit = punit'.punit.gb_red_aux
and gb_red_punit = punit'.punit.gb_red
and gb_aux_punit = punit'.punit.gb_aux_punit
and gb_punit = punit'.punit.gb_punit
and comp_min_basis_punit = punit'.punit.comp_min_basis
and comp_red_basis_aux_punit = punit'.punit.comp_red_basis_aux
and comp_red_basis_punit = punit'.punit.comp_red_basis
and monic_punit = punit'.punit.monic
and comp_red_monic_basis_punit = punit'.punit.comp_red_monic_basis
and rgb_punit = punit'.punit.rgb_punit
subgoal by (fact gd_powerprod_ord_pp_punit)
subgoal by (fact punit_adds_term)
subgoal by (simp add: id_def)
subgoal by (fact punit_component_of_term)
subgoal by (simp only: monom_mult_punit_def)
subgoal by (simp only: mult_scalar_punit_def)
subgoal using min_term_punit_def by fastforce
subgoal by (simp only: lt_punit_def ord_pp_punit_alt)
subgoal by (simp only: lc_punit_def ord_pp_punit_alt)
subgoal by (simp only: tail_punit_def ord_pp_punit_alt)
subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt)
subgoal by (simp only: ord_strict_p_punit_def ord_pp_strict_punit_alt)
done
lemma compute_spoly_punit [code]:
"spoly_punit to p q = (let t1 = lt_punit to p; t2 = lt_punit to q; l = lcs t1 t2 in
(monom_mult_punit (1 / lc_punit to p) (l - t1) p) - (monom_mult_punit (1 / lc_punit to q) (l - t2) q))"
by (simp add: punit'.punit.spoly_def Let_def punit'.punit.lc_def)
lemma compute_trd_punit [code]: "trd_punit to fs p = trd_aux_punit to fs p (change_ord to 0)"
by (simp only: punit'.punit.trd_def change_ord_def)
experiment begin interpretation trivariate⇩0_rat .
lemma
"rgb_punit DRLEX
[
X ^ 3 - X * Y * Z⇧2,
Y⇧2 * Z - 1
] =
[
X ^ 3 * Y - X * Z,
- (X ^ 3) + X * Y * Z⇧2,
Y⇧2 * Z - 1,
- (X * Z ^ 3) + X ^ 5
]"
by eval
lemma
"rgb_punit DRLEX
[
X⇧2 + Y⇧2 + Z⇧2 - 1,
X * Y - Z - 1,
Y⇧2 + X,
Z⇧2 + X
] =
[
1
]"
by eval
text ‹Note: The above computations have been cross-checked with Mathematica 11.1.›
end
end
Theory Macaulay_Matrix
section ‹Macaulay Matrices›
theory Macaulay_Matrix
imports More_MPoly_Type_Class Jordan_Normal_Form.Gauss_Jordan_Elimination
begin
text ‹We build upon vectors and matrices represented by dimension and characteristic function, because
later on we need to quantify the dimensions of certain matrices existentially. This is not possible
(at least not easily possible) with a type-based approach, as in HOL-Multivariate Analysis.›
subsection ‹More about Vectors›
lemma vec_of_list_alt: "vec_of_list xs = vec (length xs) (nth xs)"
by (transfer, rule refl)
lemma vec_cong:
assumes "n = m" and "⋀i. i < m ⟹ f i = g i"
shows "vec n f = vec m g"
using assms by auto
lemma scalar_prod_comm:
assumes "dim_vec v = dim_vec w"
shows "v ∙ w = w ∙ (v::'a::comm_semiring_0 vec)"
by (simp add: scalar_prod_def assms, rule sum.cong, rule refl, simp only: ac_simps)
lemma vec_scalar_mult_fun: "vec n (λx. c * f x) = c ⋅⇩v vec n f"
by (simp add: smult_vec_def, rule vec_cong, rule refl, simp)
definition mult_vec_mat :: "'a vec ⇒ 'a :: semiring_0 mat ⇒ 'a vec" (infixl "⇩v*" 70)
where "v ⇩v* A ≡ vec (dim_col A) (λj. v ∙ col A j)"
definition resize_vec :: "nat ⇒ 'a vec ⇒ 'a vec"
where "resize_vec n v = vec n (vec_index v)"
lemma dim_resize_vec[simp]: "dim_vec (resize_vec n v) = n"
by (simp add: resize_vec_def)
lemma resize_vec_carrier: "resize_vec n v ∈ carrier_vec n"
by (simp add: carrier_dim_vec)
lemma resize_vec_dim[simp]: "resize_vec (dim_vec v) v = v"
by (simp add: resize_vec_def eq_vecI)
lemma resize_vec_index:
assumes "i < n"
shows "resize_vec n v $ i = v $ i"
using assms by (simp add: resize_vec_def)
lemma mult_mat_vec_resize:
"v ⇩v* A = (resize_vec (dim_row A) v) ⇩v* A"
by (simp add: mult_vec_mat_def scalar_prod_def, rule arg_cong2[of _ _ _ _ vec], rule, rule,
rule sum.cong, rule, simp add: resize_vec_index)
lemma assoc_mult_vec_mat:
assumes "v ∈ carrier_vec n1" and "A ∈ carrier_mat n1 n2" and "B ∈ carrier_mat n2 n3"
shows "v ⇩v* (A * B) = (v ⇩v* A) ⇩v* B"
using assms by (intro eq_vecI, auto simp add: mult_vec_mat_def mult_mat_vec_def assoc_scalar_prod)
lemma mult_vec_mat_transpose:
assumes "dim_vec v = dim_row A"
shows "v ⇩v* A = (transpose_mat A) *⇩v (v::'a::comm_semiring_0 vec)"
proof (simp add: mult_vec_mat_def mult_mat_vec_def, rule vec_cong, rule refl, simp)
fix j
show "v ∙ col A j = col A j ∙ v" by (rule scalar_prod_comm, simp add: assms)
qed
subsection ‹More about Matrices›
definition nzrows :: "'a::zero mat ⇒ 'a vec list"
where "nzrows A = filter (λr. r ≠ 0⇩v (dim_col A)) (rows A)"
definition row_space :: "'a mat ⇒ 'a::semiring_0 vec set"
where "row_space A = (λv. mult_vec_mat v A) ` (carrier_vec (dim_row A))"
definition row_echelon :: "'a mat ⇒ 'a::field mat"
where "row_echelon A = fst (gauss_jordan A (1⇩m (dim_row A)))"
subsubsection ‹@{const nzrows}›
lemma length_nzrows: "length (nzrows A) ≤ dim_row A"
by (simp add: nzrows_def length_rows[symmetric] del: length_rows)
lemma set_nzrows: "set (nzrows A) = set (rows A) - {0⇩v (dim_col A)}"
by (auto simp add: nzrows_def)
lemma nzrows_nth_not_zero:
assumes "i < length (nzrows A)"
shows "nzrows A ! i ≠ 0⇩v (dim_col A)"
using assms unfolding nzrows_def using nth_mem by force
subsubsection ‹@{const row_space}›
lemma row_spaceI:
assumes "x = v ⇩v* A"
shows "x ∈ row_space A"
unfolding row_space_def assms by (rule, fact mult_mat_vec_resize, fact resize_vec_carrier)
lemma row_spaceE:
assumes "x ∈ row_space A"
obtains v where "v ∈ carrier_vec (dim_row A)" and "x = v ⇩v* A"
using assms unfolding row_space_def by auto
lemma row_space_alt: "row_space A = range (λv. mult_vec_mat v A)"
proof
show "row_space A ⊆ range (λv. v ⇩v* A)" unfolding row_space_def by auto
next
show "range (λv. v ⇩v* A) ⊆ row_space A"
proof
fix x
assume "x ∈ range (λv. v ⇩v* A)"
then obtain v where "x = v ⇩v* A" ..
thus "x ∈ row_space A" by (rule row_spaceI)
qed
qed
lemma row_space_mult:
assumes "A ∈ carrier_mat nr nc" and "B ∈ carrier_mat nr nr"
shows "row_space (B * A) ⊆ row_space A"
proof
from assms(2) assms(1) have "B * A ∈ carrier_mat nr nc" by (rule mult_carrier_mat)
hence "nr = dim_row (B * A)" by blast
fix x
assume "x ∈ row_space (B * A)"
then obtain v where "v ∈ carrier_vec nr" and x: "x = v ⇩v* (B * A)"
unfolding ‹nr = dim_row (B * A)› by (rule row_spaceE)
from this(1) assms(2) assms(1) have "x = (v ⇩v* B) ⇩v* A" unfolding x by (rule assoc_mult_vec_mat)
thus "x ∈ row_space A" by (rule row_spaceI)
qed
lemma row_space_mult_unit:
assumes "P ∈ Units (ring_mat TYPE('a::semiring_1) (dim_row A) b)"
shows "row_space (P * A) = row_space A"
proof -
have A: "A ∈ carrier_mat (dim_row A) (dim_col A)" by simp
from assms have P: "P ∈ carrier (ring_mat TYPE('a) (dim_row A) b)" and
*: "∃Q∈(carrier (ring_mat TYPE('a) (dim_row A) b)).
Q ⊗⇘ring_mat TYPE('a) (dim_row A) b⇙ P = 𝟭⇘ring_mat TYPE('a) (dim_row A) b⇙"
unfolding Units_def by auto
from P have P_in: "P ∈ carrier_mat (dim_row A) (dim_row A)" by (simp add: ring_mat_def)
from * obtain Q where "Q ∈ carrier (ring_mat TYPE('a) (dim_row A) b)"
and "Q ⊗⇘ring_mat TYPE('a) (dim_row A) b⇙ P = 𝟭⇘ring_mat TYPE('a) (dim_row A) b⇙" ..
hence Q_in: "Q ∈ carrier_mat (dim_row A) (dim_row A)" and QP: "Q * P = 1⇩m (dim_row A)"
by (simp_all add: ring_mat_def)
show ?thesis
proof
from A P_in show "row_space (P * A) ⊆ row_space A" by (rule row_space_mult)
next
from A P_in Q_in have "Q * (P * A) = (Q * P) * A" by (simp only: assoc_mult_mat)
also from A have "... = A" by (simp add: QP)
finally have eq: "row_space A = row_space (Q * (P * A))" by simp
show "row_space A ⊆ row_space (P * A)" unfolding eq by (rule row_space_mult, rule mult_carrier_mat, fact+)
qed
qed
subsubsection ‹@{const row_echelon}›
lemma row_eq_zero_iff_pivot_fun:
assumes "pivot_fun A f (dim_col A)" and "i < dim_row (A::'a::zero_neq_one mat)"
shows "(row A i = 0⇩v (dim_col A)) ⟷ (f i = dim_col A)"
proof -
have *: "dim_row A = dim_row A" ..
show ?thesis
proof
assume a: "row A i = 0⇩v (dim_col A)"
show "f i = dim_col A"
proof (rule ccontr)
assume "f i ≠ dim_col A"
with pivot_funD(1)[OF * assms] have **: "f i < dim_col A" by simp
with * assms have "A $$ (i, f i) = 1" by (rule pivot_funD)
with ** assms(2) have "row A i $ (f i) = 1" by simp
hence "(1::'a) = (0⇩v (dim_col A)) $ (f i)" by (simp only: a)
also have "... = (0::'a)" using ** by simp
finally show False by simp
qed
next
assume a: "f i = dim_col A"
show "row A i = 0⇩v (dim_col A)"
proof (rule, simp_all add: assms(2))
fix j
assume "j < dim_col A"
hence "j < f i" by (simp only: a)
with * assms show "A $$ (i, j) = 0" by (rule pivot_funD)
qed
qed
qed
lemma row_not_zero_iff_pivot_fun:
assumes "pivot_fun A f (dim_col A)" and "i < dim_row (A::'a::zero_neq_one mat)"
shows "(row A i ≠ 0⇩v (dim_col A)) ⟷ (f i < dim_col A)"
proof (simp only: row_eq_zero_iff_pivot_fun[OF assms])
have "f i ≤ dim_col A" by (rule pivot_funD[where ?f = f], rule refl, fact+)
thus "(f i ≠ dim_col A) = (f i < dim_col A)" by auto
qed
lemma pivot_fun_stabilizes:
assumes "pivot_fun A f nc" and "i1 ≤ i2" and "i2 < dim_row A" and "nc ≤ f i1"
shows "f i2 = nc"
proof -
from assms(2) have "i2 = i1 + (i2 - i1)" by simp
then obtain k where "i2 = i1 + k" ..
from assms(3) assms(4) show ?thesis unfolding ‹i2 = i1 + k›
proof (induct k arbitrary: i1)
case 0
from this(1) have "i1 < dim_row A" by simp
from _ assms(1) this have "f i1 ≤ nc" by (rule pivot_funD, intro refl)
with ‹nc ≤ f i1› show ?case by simp
next
case (Suc k)
from Suc(2) have "Suc (i1 + k) < dim_row A" by simp
hence "Suc i1 + k < dim_row A" by simp
hence "Suc i1 < dim_row A" by simp
hence "i1 < dim_row A" by simp
have "nc ≤ f (Suc i1)"
proof -
have "f i1 < f (Suc i1) ∨ f (Suc i1) = nc" by (rule pivot_funD, rule refl, fact+)
with Suc(3) show ?thesis by auto
qed
with ‹Suc i1 + k < dim_row A› have "f (Suc i1 + k) = nc" by (rule Suc(1))
thus ?case by simp
qed
qed
lemma pivot_fun_mono_strict:
assumes "pivot_fun A f nc" and "i1 < i2" and "i2 < dim_row A" and "f i1 < nc"
shows "f i1 < f i2"
proof -
from assms(2) have "i2 - i1 ≠ 0" and "i2 = i1 + (i2 - i1)" by simp_all
then obtain k where "k ≠ 0" and "i2 = i1 + k" ..
from this(1) assms(3) assms(4) show ?thesis unfolding ‹i2 = i1 + k›
proof (induct k arbitrary: i1)
case 0
thus ?case by simp
next
case (Suc k)
from Suc(3) have "Suc (i1 + k) < dim_row A" by simp
hence "Suc i1 + k < dim_row A" by simp
hence "Suc i1 < dim_row A" by simp
hence "i1 < dim_row A" by simp
have *: "f i1 < f (Suc i1)"
proof -
have "f i1 < f (Suc i1) ∨ f (Suc i1) = nc" by (rule pivot_funD, rule refl, fact+)
with Suc(4) show ?thesis by auto
qed
show ?case
proof (simp, cases "k = 0")
case True
show "f i1 < f (Suc (i1 + k))" by (simp add: True *)
next
case False
have "f (Suc i1) ≤ f (Suc i1 + k)"
proof (cases "f (Suc i1) < nc")
case True
from False ‹Suc i1 + k < dim_row A› True have "f (Suc i1) < f (Suc i1 + k)" by (rule Suc(1))
thus ?thesis by simp
next
case False
hence "nc ≤ f (Suc i1)" by simp
from assms(1) _ ‹Suc i1 + k < dim_row A› this have "f (Suc i1 + k) = nc"
by (rule pivot_fun_stabilizes[where ?f=f], simp)
moreover have "f (Suc i1) = nc" by (rule pivot_fun_stabilizes[where ?f=f], fact, rule le_refl, fact+)
ultimately show ?thesis by simp
qed
also have "... = f (i1 + Suc k)" by simp
finally have "f (Suc i1) ≤ f (i1 + Suc k)" .
with * show "f i1 < f (Suc (i1 + k))" by simp
qed
qed
qed
lemma pivot_fun_mono:
assumes "pivot_fun A f nc" and "i1 ≤ i2" and "i2 < dim_row A"
shows "f i1 ≤ f i2"
proof -
from assms(2) have "i1 < i2 ∨ i1 = i2" by auto
thus ?thesis
proof
assume "i1 < i2"
show ?thesis
proof (cases "f i1 < nc")
case True
from assms(1) ‹i1 < i2› assms(3) this have "f i1 < f i2" by (rule pivot_fun_mono_strict)
thus ?thesis by simp
next
case False
hence "nc ≤ f i1" by simp
from assms(1) _ _ this have "f i1 = nc"
proof (rule pivot_fun_stabilizes[where ?f=f], simp)
from assms(2) assms(3) show "i1 < dim_row A" by (rule le_less_trans)
qed
moreover have "f i2 = nc" by (rule pivot_fun_stabilizes[where ?f=f], fact+)
ultimately show ?thesis by simp
qed
next
assume "i1 = i2"
thus ?thesis by simp
qed
qed
lemma row_echelon_carrier:
assumes "A ∈ carrier_mat nr nc"
shows "row_echelon A ∈ carrier_mat nr nc"
proof -
from assms have "dim_row A = nr" by simp
let ?B = "1⇩m (dim_row A)"
note assms
moreover have "?B ∈ carrier_mat nr nr" by (simp add: ‹dim_row A = nr›)
moreover from surj_pair obtain A' B' where *: "gauss_jordan A ?B = (A', B')" by metis
ultimately have "A' ∈ carrier_mat nr nc" by (rule gauss_jordan_carrier)
thus ?thesis by (simp add: row_echelon_def *)
qed
lemma dim_row_echelon[simp]:
shows "dim_row (row_echelon A) = dim_row A" and "dim_col (row_echelon A) = dim_col A"
proof -
have "A ∈ carrier_mat (dim_row A) (dim_col A)" by simp
hence "row_echelon A ∈ carrier_mat (dim_row A) (dim_col A)" by (rule row_echelon_carrier)
thus "dim_row (row_echelon A) = dim_row A" and "dim_col (row_echelon A) = dim_col A" by simp_all
qed
lemma row_echelon_transform:
obtains P where "P ∈ Units (ring_mat TYPE('a::field) (dim_row A) b)" and "row_echelon A = P * A"
proof -
let ?B = "1⇩m (dim_row A)"
have "A ∈ carrier_mat (dim_row A) (dim_col A)" by simp
moreover have "?B ∈ carrier_mat (dim_row A) (dim_row A)" by simp
moreover from surj_pair obtain A' B' where *: "gauss_jordan A ?B = (A', B')" by metis
ultimately have "∃P∈Units (ring_mat TYPE('a) (dim_row A) b). A' = P * A ∧ B' = P * ?B"
by (rule gauss_jordan_transform)
then obtain P where "P ∈ Units (ring_mat TYPE('a) (dim_row A) b)" and **: "A' = P * A ∧ B' = P * ?B" ..
from this(1) show ?thesis
proof
from ** have "A' = P * A" ..
thus "row_echelon A = P * A" by (simp add: row_echelon_def *)
qed
qed
lemma row_space_row_echelon[simp]: "row_space (row_echelon A) = row_space A"
proof -
obtain P where *: "P ∈ Units (ring_mat TYPE('a::field) (dim_row A) Nil)" and **: "row_echelon A = P * A"
by (rule row_echelon_transform)
from * have "row_space (P * A) = row_space A" by (rule row_space_mult_unit)
thus ?thesis by (simp only: **)
qed
lemma row_echelon_pivot_fun:
obtains f where "pivot_fun (row_echelon A) f (dim_col (row_echelon A))"
proof -
let ?B = "1⇩m (dim_row A)"
have "A ∈ carrier_mat (dim_row A) (dim_col A)" by simp
moreover from surj_pair obtain A' B' where *: "gauss_jordan A ?B = (A', B')" by metis
ultimately have "row_echelon_form A'" by (rule gauss_jordan_row_echelon)
then obtain f where "pivot_fun A' f (dim_col A')" unfolding row_echelon_form_def ..
hence "pivot_fun (row_echelon A) f (dim_col (row_echelon A))" by (simp add: row_echelon_def *)
thus ?thesis ..
qed
lemma distinct_nzrows_row_echelon: "distinct (nzrows (row_echelon A))"
unfolding nzrows_def
proof (rule distinct_filterI, simp del: dim_row_echelon)
let ?B = "row_echelon A"
fix i j::nat
assume "i < j" and "j < dim_row ?B"
hence "i ≠ j" and "i < dim_row ?B" by simp_all
assume ri: "row ?B i ≠ 0⇩v (dim_col ?B)" and rj: "row ?B j ≠ 0⇩v (dim_col ?B)"
obtain f where pf: "pivot_fun ?B f (dim_col ?B)" by (fact row_echelon_pivot_fun)
from rj have "f j < dim_col ?B" by (simp only: row_not_zero_iff_pivot_fun[OF pf ‹j < dim_row ?B›])
from _ pf ‹j < dim_row ?B› this ‹i < dim_row ?B› ‹i ≠ j› have *: "?B $$ (i, f j) = 0"
by (rule pivot_funD(5), intro refl)
show "row ?B i ≠ row ?B j"
proof
assume "row ?B i = row ?B j"
hence "row ?B i $ (f j) = row ?B j $ (f j)" by simp
with ‹i < dim_row ?B› ‹j < dim_row ?B› ‹f j < dim_col ?B› have "?B $$ (i, f j) = ?B $$ (j, f j)" by simp
also from _ pf ‹j < dim_row ?B› ‹f j < dim_col ?B› have "... = 1" by (rule pivot_funD, intro refl)
finally show False by (simp add: *)
qed
qed
subsection ‹Converting Between Polynomials and Macaulay Matrices›
definition poly_to_row :: "'a list ⇒ ('a ⇒⇩0 'b::zero) ⇒ 'b vec" where
"poly_to_row ts p = vec_of_list (map (lookup p) ts)"
definition polys_to_mat :: "'a list ⇒ ('a ⇒⇩0 'b::zero) list ⇒ 'b mat" where
"polys_to_mat ts ps = mat_of_rows (length ts) (map (poly_to_row ts) ps)"
definition list_to_fun :: "'a list ⇒ ('b::zero) list ⇒ 'a ⇒ 'b" where
"list_to_fun ts cs t = (case map_of (zip ts cs) t of Some c ⇒ c | None ⇒ 0)"
definition list_to_poly :: "'a list ⇒ 'b list ⇒ ('a ⇒⇩0 'b::zero)" where
"list_to_poly ts cs = Abs_poly_mapping (list_to_fun ts cs)"
definition row_to_poly :: "'a list ⇒ 'b vec ⇒ ('a ⇒⇩0 'b::zero)" where
"row_to_poly ts r = list_to_poly ts (list_of_vec r)"
definition mat_to_polys :: "'a list ⇒ 'b mat ⇒ ('a ⇒⇩0 'b::zero) list" where
"mat_to_polys ts A = map (row_to_poly ts) (rows A)"
lemma dim_poly_to_row: "dim_vec (poly_to_row ts p) = length ts"
by (simp add: poly_to_row_def)
lemma poly_to_row_index:
assumes "i < length ts"
shows "poly_to_row ts p $ i = lookup p (ts ! i)"
by (simp add: poly_to_row_def vec_of_list_index assms)
context term_powerprod
begin
lemma poly_to_row_scalar_mult:
assumes "keys p ⊆ set ts"
shows "row_to_poly ts (c ⋅⇩v (poly_to_row ts p)) = c ⋅ p"
proof -
have eq: "(vec (length ts) (λi. c * poly_to_row ts p $ i)) =
(vec (length ts) (λi. c * lookup p (ts ! i)))"
by (rule vec_cong, rule, simp only: poly_to_row_index)
have *: "list_to_fun ts (list_of_vec (c ⋅⇩v (poly_to_row ts p))) = (λt. c * lookup p t)"
proof (rule, simp add: list_to_fun_def smult_vec_def dim_poly_to_row eq,
simp add: map_upt[of "λx. c * lookup p x"] map_of_zip_map, rule)
fix t
assume "t ∉ set ts"
with assms(1) have "t ∉ keys p" by auto
thus "c * lookup p t = 0" by (simp add: in_keys_iff)
qed
have **: "lookup (Abs_poly_mapping (list_to_fun ts (list_of_vec (c ⋅⇩v (poly_to_row ts p))))) =
(λt. c * lookup p t)"
proof (simp only: *, rule Abs_poly_mapping_inverse, simp, rule finite_subset, rule, simp)
fix t
assume "c * lookup p t ≠ 0"
hence "lookup p t ≠ 0" using mult_not_zero by blast
thus "t ∈ keys p" by (simp add: in_keys_iff)
qed (fact finite_keys)
show ?thesis unfolding row_to_poly_def
by (rule poly_mapping_eqI) (simp only: list_to_poly_def ** lookup_map_scale)
qed
lemma poly_to_row_to_poly:
assumes "keys p ⊆ set ts"
shows "row_to_poly ts (poly_to_row ts p) = (p::'t ⇒⇩0 'b::semiring_1)"
proof -
have "1 ⋅⇩v (poly_to_row ts p) = poly_to_row ts p" by simp
thus ?thesis using poly_to_row_scalar_mult[OF assms, of 1] by simp
qed
lemma lookup_list_to_poly: "lookup (list_to_poly ts cs) = list_to_fun ts cs"
unfolding list_to_poly_def
proof (rule Abs_poly_mapping_inverse, rule, rule finite_subset)
show "{x. list_to_fun ts cs x ≠ 0} ⊆ set ts"
proof (rule, simp)
fix t
assume "list_to_fun ts cs t ≠ 0"
then obtain c where "map_of (zip ts cs) t = Some c" unfolding list_to_fun_def by fastforce
thus "t ∈ set ts" by (meson in_set_zipE map_of_SomeD)
qed
qed simp
lemma list_to_fun_Nil [simp]: "list_to_fun [] cs = 0"
by (simp only: zero_fun_def, rule, simp add: list_to_fun_def)
lemma list_to_poly_Nil [simp]: "list_to_poly [] cs = 0"
by (rule poly_mapping_eqI, simp add: lookup_list_to_poly)
lemma row_to_poly_Nil [simp]: "row_to_poly [] r = 0"
by (simp only: row_to_poly_def, fact list_to_poly_Nil)
lemma lookup_row_to_poly:
assumes "distinct ts" and "dim_vec r = length ts" and "i < length ts"
shows "lookup (row_to_poly ts r) (ts ! i) = r $ i"
proof (simp only: row_to_poly_def lookup_list_to_poly)
from assms(2) assms(3) have "i < dim_vec r" by simp
have "map_of (zip ts (list_of_vec r)) (ts ! i) = Some ((list_of_vec r) ! i)"
by (rule map_of_zip_nth, simp_all only: length_list_of_vec assms(2), fact, fact)
also have "... = Some (r $ i)" by (simp only: list_of_vec_index)
finally show "list_to_fun ts (list_of_vec r) (ts ! i) = r $ i" by (simp add: list_to_fun_def)
qed
lemma keys_row_to_poly: "keys (row_to_poly ts r) ⊆ set ts"
proof
fix t
assume "t ∈ keys (row_to_poly ts r)"
hence "lookup (row_to_poly ts r) t ≠ 0" by (simp add: in_keys_iff)
thus "t ∈ set ts"
proof (simp add: row_to_poly_def lookup_list_to_poly list_to_fun_def del: lookup_not_eq_zero_eq_in_keys
split: option.splits)
fix c
assume "map_of (zip ts (list_of_vec r)) t = Some c"
thus "t ∈ set ts" by (meson in_set_zipE map_of_SomeD)
qed
qed
lemma lookup_row_to_poly_not_zeroE:
assumes "lookup (row_to_poly ts r) t ≠ 0"
obtains i where "i < length ts" and "t = ts ! i"
proof -
from assms have "t ∈ keys (row_to_poly ts r)" by (simp add: in_keys_iff)
have "t ∈ set ts" by (rule, fact, fact keys_row_to_poly)
then obtain i where "i < length ts" and "t = ts ! i" by (metis in_set_conv_nth)
thus ?thesis ..
qed
lemma row_to_poly_zero [simp]: "row_to_poly ts (0⇩v (length ts)) = (0::'t ⇒⇩0 'b::zero)"
proof -
have eq: "map (λ_. 0::'b) [0..<length ts] = map (λ_. 0) ts" by (simp add: map_replicate_const)
show ?thesis
by (simp add: row_to_poly_def zero_vec_def, rule poly_mapping_eqI,
simp add: lookup_list_to_poly list_to_fun_def eq map_of_zip_map)
qed
lemma row_to_poly_zeroD:
assumes "distinct ts" and "dim_vec r = length ts" and "row_to_poly ts r = 0"
shows "r = 0⇩v (length ts)"
proof (rule, simp_all add: assms(2))
fix i
assume "i < length ts"
from assms(3) have "0 = lookup (row_to_poly ts r) (ts ! i)" by simp
also from assms(1) assms(2) ‹i < length ts› have "... = r $ i" by (rule lookup_row_to_poly)
finally show "r $ i = 0" by simp
qed
lemma row_to_poly_inj:
assumes "distinct ts" and "dim_vec r1 = length ts" and "dim_vec r2 = length ts"
and "row_to_poly ts r1 = row_to_poly ts r2"
shows "r1 = r2"
proof (rule, simp_all add: assms(2) assms(3))
fix i
assume "i < length ts"
have "r1 $ i = lookup (row_to_poly ts r1) (ts ! i)"
by (simp only: lookup_row_to_poly[OF assms(1) assms(2) ‹i < length ts›])
also from assms(4) have "... = lookup (row_to_poly ts r2) (ts ! i)" by simp
also from assms(1) assms(3) ‹i < length ts› have "... = r2 $ i" by (rule lookup_row_to_poly)
finally show "r1 $ i = r2 $ i" .
qed
lemma row_to_poly_vec_plus:
assumes "distinct ts" and "length ts = n"
shows "row_to_poly ts (vec n (f1 + f2)) = row_to_poly ts (vec n f1) + row_to_poly ts (vec n f2)"
proof (rule poly_mapping_eqI)
fix t
show "lookup (row_to_poly ts (vec n (f1 + f2))) t =
lookup (row_to_poly ts (vec n f1) + row_to_poly ts (vec n f2)) t"
(is "lookup ?l t = lookup (?r1 + ?r2) t")
proof (cases "t ∈ set ts")
case True
then obtain j where j: "j < length ts" and t: "t = ts ! j" by (metis in_set_conv_nth)
have d1: "dim_vec (vec n f1) = length ts" and d2: "dim_vec (vec n f2) = length ts"
and da: "dim_vec (vec n (f1 + f2)) = length ts" by (simp_all add: assms(2))
from j have j': "j < n" by (simp only: assms(2))
show ?thesis
by (simp only: t lookup_add lookup_row_to_poly[OF assms(1) d1 j]
lookup_row_to_poly[OF assms(1) d2 j] lookup_row_to_poly[OF assms(1) da j] index_vec[OF j'],
simp only: plus_fun_def)
next
case False
with keys_row_to_poly[of ts "vec n (f1 + f2)"] keys_row_to_poly[of ts "vec n f1"]
keys_row_to_poly[of ts "vec n f2"] have "t ∉ keys ?l" and "t ∉ keys ?r1" and "t ∉ keys ?r2"
by auto
from this(2) this(3) have "t ∉ keys (?r1 + ?r2)"
by (meson Poly_Mapping.keys_add UnE in_mono)
with ‹t ∉ keys ?l› show ?thesis by (simp add: in_keys_iff)
qed
qed
lemma row_to_poly_vec_sum:
assumes "distinct ts" and "length ts = n"
shows "row_to_poly ts (vec n (λj. ∑i∈I. f i j)) = ((∑i∈I. row_to_poly ts (vec n (f i)))::'t ⇒⇩0 'b::comm_monoid_add)"
proof (cases "finite I")
case True
thus ?thesis
proof (induct I)
case empty
thus ?case by (simp add: zero_vec_def[symmetric] assms(2)[symmetric])
next
case (insert x I)
have "row_to_poly ts (vec n (λj. ∑i∈insert x I. f i j)) = row_to_poly ts (vec n (λj. f x j + (∑i∈I. f i j)))"
by (simp add: insert(1) insert(2))
also have "... = row_to_poly ts (vec n (f x + (λj. (∑i∈I. f i j))))" by (simp only: plus_fun_def)
also from assms have "... = row_to_poly ts (vec n (f x)) + row_to_poly ts (vec n (λj. (∑i∈I. f i j)))"
by (rule row_to_poly_vec_plus)
also have "... = row_to_poly ts (vec n (f x)) + (∑i∈I. row_to_poly ts (vec n (f i)))"
by (simp only: insert(3))
also have "... = (∑i∈insert x I. row_to_poly ts (vec n (f i)))"
by (simp add: insert(1) insert(2))
finally show ?case .
qed
next
case False
thus ?thesis by (simp add: zero_vec_def[symmetric] assms(2)[symmetric])
qed
lemma row_to_poly_smult:
assumes "distinct ts" and "dim_vec r = length ts"
shows "row_to_poly ts (c ⋅⇩v r) = c ⋅ (row_to_poly ts r)"
proof (rule poly_mapping_eqI, simp only: lookup_map_scale)
fix t
show "lookup (row_to_poly ts (c ⋅⇩v r)) t = c * lookup (row_to_poly ts r) t" (is "lookup ?l t = c * lookup ?r t")
proof (cases "t ∈ set ts")
case True
then obtain j where j: "j < length ts" and t: "t = ts ! j" by (metis in_set_conv_nth)
from assms(2) have dm: "dim_vec (c ⋅⇩v r) = length ts" by simp
from j have j': "j < dim_vec r" by (simp only: assms(2))
show ?thesis
by (simp add: t lookup_row_to_poly[OF assms j] lookup_row_to_poly[OF assms(1) dm j] index_smult_vec(1)[OF j'])
next
case False
with keys_row_to_poly[of ts "c ⋅⇩v r"] keys_row_to_poly[of ts r] have
"t ∉ keys ?l" and "t ∉ keys ?r" by auto
thus ?thesis by (simp add: in_keys_iff)
qed
qed
lemma poly_to_row_Nil [simp]: "poly_to_row [] p = vec 0 f"
proof -
have "dim_vec (poly_to_row [] p) = 0" by (simp add: dim_poly_to_row)
thus ?thesis by auto
qed
lemma polys_to_mat_Nil [simp]: "polys_to_mat ts [] = mat 0 (length ts) f"
by (simp add: polys_to_mat_def mat_eq_iff)
lemma dim_row_polys_to_mat[simp]: "dim_row (polys_to_mat ts ps) = length ps"
by (simp add: polys_to_mat_def)
lemma dim_col_polys_to_mat[simp]: "dim_col (polys_to_mat ts ps) = length ts"
by (simp add: polys_to_mat_def)
lemma polys_to_mat_index:
assumes "i < length ps" and "j < length ts"
shows "(polys_to_mat ts ps) $$ (i, j) = lookup (ps ! i) (ts ! j)"
by (simp add: polys_to_mat_def index_mat(1)[OF assms] mat_of_rows_def nth_map[OF assms(1)],
rule poly_to_row_index, fact)
lemma row_polys_to_mat:
assumes "i < length ps"
shows "row (polys_to_mat ts ps) i = poly_to_row ts (ps ! i)"
proof -
have "row (polys_to_mat ts ps) i = (map (poly_to_row ts) ps) ! i" unfolding polys_to_mat_def
proof (rule mat_of_rows_row)
from assms show "i < length (map (poly_to_row ts) ps)" by simp
next
show "map (poly_to_row ts) ps ! i ∈ carrier_vec (length ts)" unfolding nth_map[OF assms]
by (rule carrier_vecI, fact dim_poly_to_row)
qed
also from assms have "... = poly_to_row ts (ps ! i)" by (rule nth_map)
finally show ?thesis .
qed
lemma col_polys_to_mat:
assumes "j < length ts"
shows "col (polys_to_mat ts ps) j = vec_of_list (map (λp. lookup p (ts ! j)) ps)"
by (simp add: vec_of_list_alt col_def, rule vec_cong, rule refl, simp add: polys_to_mat_index assms)
lemma length_mat_to_polys[simp]: "length (mat_to_polys ts A) = dim_row A"
by (simp add: mat_to_polys_def mat_to_list_def)
lemma mat_to_polys_nth:
assumes "i < dim_row A"
shows "(mat_to_polys ts A) ! i = row_to_poly ts (row A i)"
proof -
from assms have "i < length (rows A)" by (simp only: length_rows)
thus ?thesis by (simp add: mat_to_polys_def)
qed
lemma Keys_mat_to_polys: "Keys (set (mat_to_polys ts A)) ⊆ set ts"
proof
fix t
assume "t ∈ Keys (set (mat_to_polys ts A))"
then obtain p where "p ∈ set (mat_to_polys ts A)" and t: "t ∈ keys p" by (rule in_KeysE)
from this(1) obtain i where "i < length (mat_to_polys ts A)" and p: "p = (mat_to_polys ts A) ! i"
by (metis in_set_conv_nth)
from this(1) have "i < dim_row A" by simp
with p have "p = row_to_poly ts (row A i)" by (simp only: mat_to_polys_nth)
with t have "t ∈ keys (row_to_poly ts (row A i))" by simp
also have "... ⊆ set ts" by (fact keys_row_to_poly)
finally show "t ∈ set ts" .
qed
lemma polys_to_mat_to_polys:
assumes "Keys (set ps) ⊆ set ts"
shows "mat_to_polys ts (polys_to_mat ts ps) = (ps::('t ⇒⇩0 'b::semiring_1) list)"
unfolding mat_to_polys_def mat_to_list_def
proof (rule nth_equalityI, simp_all)
fix i
assume "i < length ps"
have *: "keys (ps ! i) ⊆ set ts"
using ‹i < length ps› assms keys_subset_Keys nth_mem by blast
show "row_to_poly ts (row (polys_to_mat ts ps) i) = ps ! i"
by (simp only: row_polys_to_mat[OF ‹i < length ps›] poly_to_row_to_poly[OF *])
qed
lemma mat_to_polys_to_mat:
assumes "distinct ts" and "length ts = dim_col A"
shows "(polys_to_mat ts (mat_to_polys ts A)) = A"
proof
fix i j
assume i: "i < dim_row A" and j: "j < dim_col A"
hence i': "i < length (mat_to_polys ts A)" and j': "j < length ts" by (simp, simp only: assms(2))
have r: "dim_vec (row A i) = length ts" by (simp add: assms(2))
show "polys_to_mat ts (mat_to_polys ts A) $$ (i, j) = A $$ (i, j)"
by (simp only: polys_to_mat_index[OF i' j'] mat_to_polys_nth[OF ‹i < dim_row A›]
lookup_row_to_poly[OF assms(1) r j'] index_row(1)[OF i j])
qed (simp_all add: assms)
subsection ‹Properties of Macaulay Matrices›
lemma row_to_poly_vec_times:
assumes "distinct ts" and "length ts = dim_col A"
shows "row_to_poly ts (v ⇩v* A) = ((∑i=0..<dim_row A. (v $ i) ⋅ (row_to_poly ts (row A i)))::'t ⇒⇩0 'b::comm_semiring_0)"
proof (simp add: mult_vec_mat_def scalar_prod_def row_to_poly_vec_sum[OF assms], rule sum.cong, rule)
fix i
assume "i ∈ {0..<dim_row A}"
hence "i < dim_row A" by simp
have "dim_vec (row A i) = length ts" by (simp add: assms(2))
have *: "vec (dim_col A) (λj. col A j $ i) = vec (dim_col A) (λj. A $$ (i, j))"
by (rule vec_cong, rule refl, simp add: ‹i < dim_row A›)
have "vec (dim_col A) (λj. v $ i * col A j $ i) = v $ i ⋅⇩v vec (dim_col A) (λj. col A j $ i)"
by (simp only: vec_scalar_mult_fun)
also have "... = v $ i ⋅⇩v (row A i)" by (simp only: * row_def[symmetric])
finally show "row_to_poly ts (vec (dim_col A) (λj. v $ i * col A j $ i)) =
(v $ i) ⋅ (row_to_poly ts (row A i))"
by (simp add: row_to_poly_smult[OF assms(1) ‹dim_vec (row A i) = length ts›])
qed
lemma vec_times_polys_to_mat:
assumes "Keys (set ps) ⊆ set ts" and "v ∈ carrier_vec (length ps)"
shows "row_to_poly ts (v ⇩v* (polys_to_mat ts ps)) = (∑(c, p)←zip (list_of_vec v) ps. c ⋅ p)"
(is "?l = ?r")
proof -
from assms have *: "dim_vec v = length ps" by (simp only: carrier_dim_vec)
have eq: "map (λi. v ∙ col (polys_to_mat ts ps) i) [0..<length ts] =
map (λs. v ∙ (vec_of_list (map (λp. lookup p s) ps))) ts"
proof (rule nth_equalityI, simp_all)
fix i
assume "i < length ts"
hence "col (polys_to_mat ts ps) i = vec_of_list (map (λp. lookup p (ts ! i)) ps)"
by (rule col_polys_to_mat)
thus "v ∙ col (polys_to_mat ts ps) i = v ∙ map_vec (λp. lookup p (ts ! i)) (vec_of_list ps)"
by simp
qed
show ?thesis
proof (rule poly_mapping_eqI, simp add: mult_vec_mat_def row_to_poly_def lookup_list_to_poly
eq list_to_fun_def map_of_zip_map lookup_sum_list o_def, intro conjI impI)
fix t
assume "t ∈ set ts"
have "v ∙ vec_of_list (map (λp. lookup p t) ps) =
(∑(c, p)←zip (list_of_vec v) ps. lookup (c ⋅ p) t)"
proof (simp add: scalar_prod_def vec_of_list_index)
have "(∑i = 0..<length ps. v $ i * lookup (ps ! i) t) =
(∑i = 0..<length ps. (list_of_vec v) ! i * lookup (ps ! i) t)"
by (rule sum.cong, rule refl, simp add: *)
also have "... = (∑(c, p)←zip (list_of_vec v) ps. c * lookup p t)"
by (simp only: sum_set_upt_eq_sum_list, rule sum_list_upt_zip, simp only: length_list_of_vec *)
finally show "(∑i = 0..<length ps. v $ i * lookup (ps ! i) t) =
(∑(c, p)←zip (list_of_vec v) ps. c * lookup p t)" .
qed
thus "v ∙ map_vec (λp. lookup p t) (vec_of_list ps) =
(∑x←zip (list_of_vec v) ps. lookup (case x of (c, x) ⇒ c ⋅ x) t)"
by (metis (mono_tags, lifting) case_prod_conv cond_case_prod_eta vec_of_list_map)
next
fix t
assume "t ∉ set ts"
with assms(1) have "t ∉ Keys (set ps)" by auto
have "(∑(c, p)←zip (list_of_vec v) ps. lookup (c ⋅ p) t) = 0"
proof (rule sum_list_zeroI, rule, simp)
fix x
assume "x ∈ (λ(c, p). c * lookup p t) ` set (zip (list_of_vec v) ps)"
then obtain c p where cp: "(c, p) ∈ set (zip (list_of_vec v) ps)"
and x: "x = c * lookup p t" by auto
from cp have "p ∈ set ps" by (rule set_zip_rightD)
with ‹t ∉ Keys (set ps)› have "t ∉ keys p" by (auto intro: in_KeysI)
thus "x = 0" by (simp add: x in_keys_iff)
qed
thus "(∑x←zip (list_of_vec v) ps. lookup (case x of (c, x) ⇒ c ⋅ x) t) = 0"
by (metis (mono_tags, lifting) case_prod_conv cond_case_prod_eta)
qed
qed
lemma row_space_subset_phull:
assumes "Keys (set ps) ⊆ set ts"
shows "row_to_poly ts ` row_space (polys_to_mat ts ps) ⊆ phull (set ps)"
(is "?r ⊆ ?h")
proof
fix q
assume "q ∈ ?r"
then obtain x where x1: "x ∈ row_space (polys_to_mat ts ps)"
and q1: "q = row_to_poly ts x" ..
from x1 obtain v where v: "v ∈ carrier_vec (dim_row (polys_to_mat ts ps))" and x: "x = v ⇩v* polys_to_mat ts ps"
by (rule row_spaceE)
from v have "v ∈ carrier_vec (length ps)" by (simp only: dim_row_polys_to_mat)
thm vec_times_polys_to_mat
with x q1 have q: "q = (∑(c, p)←zip (list_of_vec v) ps. c ⋅ p)"
by (simp add: vec_times_polys_to_mat[OF assms])
show "q ∈ ?h" unfolding q by (rule phull.span_listI)
qed
lemma phull_subset_row_space:
assumes "Keys (set ps) ⊆ set ts"
shows "phull (set ps) ⊆ row_to_poly ts ` row_space (polys_to_mat ts ps)"
(is "?h ⊆ ?r")
proof
fix q
assume "q ∈ ?h"
then obtain cs where l: "length cs = length ps" and q: "q = (∑(c, p)←zip cs ps. c ⋅ p)"
by (rule phull.span_listE)
let ?v = "vec_of_list cs"
from l have *: "?v ∈ carrier_vec (length ps)" by (simp only: carrier_dim_vec dim_vec_of_list)
let ?q = "?v ⇩v* polys_to_mat ts ps"
show "q ∈ ?r"
proof
show "q = row_to_poly ts ?q"
by (simp add: vec_times_polys_to_mat[OF assms *] q list_vec)
next
show "?q ∈ row_space (polys_to_mat ts ps)" by (rule row_spaceI, rule)
qed
qed
lemma row_space_eq_phull:
assumes "Keys (set ps) ⊆ set ts"
shows "row_to_poly ts ` row_space (polys_to_mat ts ps) = phull (set ps)"
by (rule, rule row_space_subset_phull, fact, rule phull_subset_row_space, fact)
lemma row_space_row_echelon_eq_phull:
assumes "Keys (set ps) ⊆ set ts"
shows "row_to_poly ts ` row_space (row_echelon (polys_to_mat ts ps)) = phull (set ps)"
by (simp add: row_space_eq_phull[OF assms])
lemma phull_row_echelon:
assumes "Keys (set ps) ⊆ set ts" and "distinct ts"
shows "phull (set (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))) = phull (set ps)"
proof -
have len_ts: "length ts = dim_col (row_echelon (polys_to_mat ts ps))" by simp
have *: "Keys (set (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))) ⊆ set ts"
by (fact Keys_mat_to_polys)
show ?thesis
by (simp only: row_space_eq_phull[OF *, symmetric] mat_to_polys_to_mat[OF assms(2) len_ts],
rule row_space_row_echelon_eq_phull, fact)
qed
lemma pmdl_row_echelon:
assumes "Keys (set ps) ⊆ set ts" and "distinct ts"
shows "pmdl (set (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))) = pmdl (set ps)"
(is "?l = ?r")
proof
show "?l ⊆ ?r"
by (rule pmdl.span_subset_spanI, rule subset_trans, rule phull.span_superset,
simp only: phull_row_echelon[OF assms] phull_subset_module)
next
show "?r ⊆ ?l"
by (rule pmdl.span_subset_spanI, rule subset_trans, rule phull.span_superset,
simp only: phull_row_echelon[OF assms, symmetric] phull_subset_module)
qed
end
context ordered_term
begin
lemma lt_row_to_poly_pivot_fun:
assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)"
and "i < dim_row A" and "f i < dim_col A"
shows "lt ((mat_to_polys (pps_to_list S) A) ! i) = (pps_to_list S) ! (f i)"
proof -
let ?ts = "pps_to_list S"
have len_ts: "length ?ts = dim_col A" by (simp add: length_pps_to_list assms(1))
show ?thesis
proof (simp add: mat_to_polys_nth[OF assms(3)], rule lt_eqI)
have "lookup (row_to_poly ?ts (row A i)) (?ts ! f i) = (row A i) $ (f i)"
by (rule lookup_row_to_poly, fact distinct_pps_to_list, simp_all add: len_ts assms(4))
also have "... = A $$ (i, f i)" using assms(3) assms(4) by simp
also have "... = 1" by (rule pivot_funD, rule refl, fact+)
finally show "lookup (row_to_poly ?ts (row A i)) (?ts ! f i) ≠ 0" by simp
next
fix u
assume a: "lookup (row_to_poly ?ts (row A i)) u ≠ 0"
then obtain j where j: "j < length ?ts" and u: "u = ?ts ! j"
by (rule lookup_row_to_poly_not_zeroE)
from j have "j < card S" and "j < dim_col A" by (simp only: length_pps_to_list, simp only: len_ts)
from a have "0 ≠ lookup (row_to_poly ?ts (row A i)) (?ts ! j)" by (simp add: u)
also have "lookup (row_to_poly ?ts (row A i)) (?ts ! j) = (row A i) $ j"
by (rule lookup_row_to_poly, fact distinct_pps_to_list, simp add: len_ts, fact)
finally have "A $$ (i, j) ≠ 0" using assms(3) ‹j < dim_col A› by simp
from _ ‹j < card S› show "u ≼⇩t ?ts ! f i" unfolding u
proof (rule pps_to_list_nth_leI)
show "f i ≤ j"
proof (rule ccontr)
assume "¬ f i ≤ j"
hence "j < f i" by simp
have "A $$ (i, j) = 0" by (rule pivot_funD, rule refl, fact+)
with ‹A $$ (i, j) ≠ 0› show False ..
qed
qed
qed
qed
lemma lc_row_to_poly_pivot_fun:
assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)"
and "i < dim_row A" and "f i < dim_col A"
shows "lc ((mat_to_polys (pps_to_list S) A) ! i) = 1"
proof -
let ?ts = "pps_to_list S"
have len_ts: "length ?ts = dim_col A" by (simp only: length_pps_to_list assms(1))
have "lookup (row_to_poly ?ts (row A i)) (?ts ! f i) = (row A i) $ (f i)"
by (rule lookup_row_to_poly, fact distinct_pps_to_list, simp_all add: len_ts assms(4))
also have "... = A $$ (i, f i)" using assms(3) assms(4) by simp
finally have eq: "lookup (row_to_poly ?ts (row A i)) (?ts ! f i) = A $$ (i, f i)" .
show ?thesis
by (simp only: lc_def lt_row_to_poly_pivot_fun[OF assms], simp only: mat_to_polys_nth[OF assms(3)] eq,
rule pivot_funD, rule refl, fact+)
qed
lemma lt_row_to_poly_pivot_fun_less:
assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)"
and "i1 < i2" and "i2 < dim_row A" and "f i1 < dim_col A" and "f i2 < dim_col A"
shows "(pps_to_list S) ! (f i2) ≺⇩t (pps_to_list S) ! (f i1)"
proof -
let ?ts = "pps_to_list S"
have len_ts: "length ?ts = dim_col A" by (simp add: length_pps_to_list assms(1))
from assms(3) assms(4) have "i1 < dim_row A" by simp
show ?thesis
by (rule pps_to_list_nth_lessI, rule pivot_fun_mono_strict[where ?f=f], fact, fact, fact, fact,
simp only: assms(1) assms(6))
qed
lemma lt_row_to_poly_pivot_fun_eqD:
assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)"
and "i1 < dim_row A" and "i2 < dim_row A" and "f i1 < dim_col A" and "f i2 < dim_col A"
and "(pps_to_list S) ! (f i1) = (pps_to_list S) ! (f i2)"
shows "i1 = i2"
proof (rule linorder_cases)
assume "i1 < i2"
from assms(1) assms(2) this assms(4) assms(5) assms(6) have
"(pps_to_list S) ! (f i2) ≺⇩t (pps_to_list S) ! (f i1)" by (rule lt_row_to_poly_pivot_fun_less)
with assms(7) show ?thesis by auto
next
assume "i2 < i1"
from assms(1) assms(2) this assms(3) assms(6) assms(5) have
"(pps_to_list S) ! (f i1) ≺⇩t (pps_to_list S) ! (f i2)" by (rule lt_row_to_poly_pivot_fun_less)
with assms(7) show ?thesis by auto
qed
lemma lt_row_to_poly_pivot_in_keysD:
assumes "card S = dim_col (A::'b::semiring_1 mat)" and "pivot_fun A f (dim_col A)"
and "i1 < dim_row A" and "i2 < dim_row A" and "f i1 < dim_col A"
and "(pps_to_list S) ! (f i1) ∈ keys ((mat_to_polys (pps_to_list S) A) ! i2)"
shows "i1 = i2"
proof (rule ccontr)
assume "i1 ≠ i2"
hence "i2 ≠ i1" by simp
let ?ts = "pps_to_list S"
have len_ts: "length ?ts = dim_col A" by (simp only: length_pps_to_list assms(1))
from assms(6) have "0 ≠ lookup (row_to_poly ?ts (row A i2)) (?ts ! (f i1))"
by (auto simp: mat_to_polys_nth[OF assms(4)])
also have "lookup (row_to_poly ?ts (row A i2)) (?ts ! (f i1)) = (row A i2) $ (f i1)"
by (rule lookup_row_to_poly, fact distinct_pps_to_list, simp_all add: len_ts assms(5))
finally have "A $$ (i2, f i1) ≠ 0" using assms(4) assms(5) by simp
moreover have "A $$ (i2, f i1) = 0" by (rule pivot_funD(5), rule refl, fact+)
ultimately show False ..
qed
lemma lt_row_space_pivot_fun:
assumes "card S = dim_col (A::'b::{comm_semiring_0,semiring_1_no_zero_divisors} mat)"
and "pivot_fun A f (dim_col A)" and "p ∈ row_to_poly (pps_to_list S) ` row_space A" and "p ≠ 0"
shows "lt p ∈ lt_set (set (mat_to_polys (pps_to_list S) A))"
proof -
let ?ts = "pps_to_list S"
let ?I = "{0..<dim_row A}"
have len_ts: "length ?ts = dim_col A" by (simp add: length_pps_to_list assms(1))
from assms(3) obtain x where "x ∈ row_space A" and p: "p = row_to_poly ?ts x" ..
from this(1) obtain v where "v ∈ carrier_vec (dim_row A)" and x: "x = v ⇩v* A" by (rule row_spaceE)
have p': "p = (∑i∈?I. (v $ i) ⋅ (row_to_poly ?ts (row A i)))"
unfolding p x by (rule row_to_poly_vec_times, fact distinct_pps_to_list, fact len_ts)
have "lt (∑i = 0..<dim_row A. (v $ i) ⋅ (row_to_poly ?ts (row A i)))
∈ lt_set ((λi. (v $ i) ⋅ (row_to_poly ?ts (row A i))) ` {0..<dim_row A})"
proof (rule lt_sum_distinct_in_lt_set, rule, simp add: p'[symmetric] ‹p ≠ 0›)
fix i1 i2
let ?p1 = "(v $ i1) ⋅ (row_to_poly ?ts (row A i1))"
let ?p2 = "(v $ i2) ⋅ (row_to_poly ?ts (row A i2))"
assume "i1 ∈ ?I" and "i2 ∈ ?I"
hence "i1 < dim_row A" and "i2 < dim_row A" by simp_all
assume "?p1 ≠ 0"
hence "v $ i1 ≠ 0" and "row_to_poly ?ts (row A i1) ≠ 0" by auto
hence "row A i1 ≠ 0⇩v (length ?ts)" by auto
hence "f i1 < dim_col A"
by (simp add: len_ts row_not_zero_iff_pivot_fun[OF assms(2) ‹i1 < dim_row A›])
have "lt ?p1 = lt (row_to_poly ?ts (row A i1))" by (rule lt_map_scale, fact)
also have "... = lt ((mat_to_polys ?ts A) ! i1)" by (simp only: mat_to_polys_nth[OF ‹i1 < dim_row A›])
also have "... = ?ts ! (f i1)" by (rule lt_row_to_poly_pivot_fun, fact+)
finally have lt1: "lt ?p1 = ?ts ! (f i1)" .
assume "?p2 ≠ 0"
hence "v $ i2 ≠ 0" and "row_to_poly ?ts (row A i2) ≠ 0" by auto
hence "row A i2 ≠ 0⇩v (length ?ts)" by auto
hence "f i2 < dim_col A"
by (simp add: len_ts row_not_zero_iff_pivot_fun[OF assms(2) ‹i2 < dim_row A›])
have "lt ?p2 = lt (row_to_poly ?ts (row A i2))" by (rule lt_map_scale, fact)
also have "... = lt ((mat_to_polys ?ts A) ! i2)" by (simp only: mat_to_polys_nth[OF ‹i2 < dim_row A›])
also have "... = ?ts ! (f i2)" by (rule lt_row_to_poly_pivot_fun, fact+)
finally have lt2: "lt ?p2 = ?ts ! (f i2)" .
assume "lt ?p1 = lt ?p2"
with assms(1) assms(2) ‹i1 < dim_row A› ‹i2 < dim_row A› ‹f i1 < dim_col A› ‹f i2 < dim_col A›
show "i1 = i2" unfolding lt1 lt2 by (rule lt_row_to_poly_pivot_fun_eqD)
qed
also have "... ⊆ lt_set ((λi. row_to_poly ?ts (row A i)) ` {0..<dim_row A})"
proof
fix s
assume "s ∈ lt_set ((λi. (v $ i) ⋅ (row_to_poly ?ts (row A i))) ` {0..<dim_row A})"
then obtain f
where "f ∈ (λi. (v $ i) ⋅ (row_to_poly ?ts (row A i))) ` {0..<dim_row A}"
and "f ≠ 0" and "lt f = s" by (rule lt_setE)
from this(1) obtain i where "i ∈ {0..<dim_row A}"
and f: "f = (v $ i) ⋅ (row_to_poly ?ts (row A i))" ..
from this(2) ‹f ≠ 0› have "v $ i ≠ 0" and **: "row_to_poly ?ts (row A i) ≠ 0" by auto
from ‹lt f = s› have "s = lt ((v $ i) ⋅ (row_to_poly ?ts (row A i)))" by (simp only: f)
also from ‹v $ i ≠ 0› have "... = lt (row_to_poly ?ts (row A i))" by (rule lt_map_scale)
finally have s: "s = lt (row_to_poly ?ts (row A i))" .
show "s ∈ lt_set ((λi. row_to_poly ?ts (row A i)) ` {0..<dim_row A})"
unfolding s by (rule lt_setI, rule, rule refl, fact+)
qed
also have "... = lt_set ((λr. row_to_poly ?ts r) ` (row A ` {0..<dim_row A}))"
by (simp only: image_comp o_def)
also have "... = lt_set (set (map (λr. row_to_poly ?ts r) (map (row A) [0..<dim_row A])))"
by (metis image_set set_upt)
also have "... = lt_set (set (mat_to_polys ?ts A))" by (simp only: mat_to_polys_def rows_def)
finally show ?thesis unfolding p' .
qed
subsection ‹Functions ‹Macaulay_mat› and ‹Macaulay_list››
definition Macaulay_mat :: "('t ⇒⇩0 'b) list ⇒ 'b::field mat"
where "Macaulay_mat ps = polys_to_mat (Keys_to_list ps) ps"
definition Macaulay_list :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list"
where "Macaulay_list ps =
filter (λp. p ≠ 0) (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps)))"
lemma dim_Macaulay_mat[simp]:
"dim_row (Macaulay_mat ps) = length ps"
"dim_col (Macaulay_mat ps) = card (Keys (set ps))"
by (simp_all add: Macaulay_mat_def length_Keys_to_list)
lemma Macaulay_list_Nil [simp]: "Macaulay_list [] = ([]::('t ⇒⇩0 'b::field) list)" (is "?l = _")
proof -
have "length ?l ≤ length (mat_to_polys (Keys_to_list ([]::('t ⇒⇩0 'b) list))
(row_echelon (Macaulay_mat ([]::('t ⇒⇩0 'b) list))))"
unfolding Macaulay_list_def by (fact length_filter_le)
also have "... = 0" by simp
finally show ?thesis by simp
qed
lemma set_Macaulay_list:
"set (Macaulay_list ps) =
set (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps))) - {0}"
by (auto simp add: Macaulay_list_def)
lemma Keys_Macaulay_list: "Keys (set (Macaulay_list ps)) ⊆ Keys (set ps)"
proof -
have "Keys (set (Macaulay_list ps)) ⊆ set (Keys_to_list ps)"
by (simp only: set_Macaulay_list Keys_minus_zero, fact Keys_mat_to_polys)
also have "... = Keys (set ps)" by (fact set_Keys_to_list)
finally show ?thesis .
qed
lemma in_Macaulay_listE:
assumes "p ∈ set (Macaulay_list ps)"
and "pivot_fun (row_echelon (Macaulay_mat ps)) f (dim_col (row_echelon (Macaulay_mat ps)))"
obtains i where "i < dim_row (row_echelon (Macaulay_mat ps))"
and "p = (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps))) ! i"
and "f i < dim_col (row_echelon (Macaulay_mat ps))"
proof -
let ?ts = "Keys_to_list ps"
let ?A = "Macaulay_mat ps"
let ?E = "row_echelon ?A"
from assms(1) have "p ∈ set (mat_to_polys ?ts ?E) - {0}" by (simp add: set_Macaulay_list)
hence "p ∈ set (mat_to_polys ?ts ?E)" and "p ≠ 0" by auto
from this(1) obtain i where "i < length (mat_to_polys ?ts ?E)" and p: "p = (mat_to_polys ?ts ?E) ! i"
by (metis in_set_conv_nth)
from this(1) have "i < dim_row ?E" and "i < dim_row ?A" by simp_all
from this(1) p show ?thesis
proof
from ‹p ≠ 0› have "0 ≠ (mat_to_polys ?ts ?E) ! i" by (simp only: p)
also have "(mat_to_polys ?ts ?E) ! i = row_to_poly ?ts (row ?E i)"
by (simp only: Macaulay_list_def mat_to_polys_nth[OF ‹i < dim_row ?E›])
finally have *: "row_to_poly ?ts (row ?E i) ≠ 0" by simp
have "row ?E i ≠ 0⇩v (length ?ts)"
proof
assume "row ?E i = 0⇩v (length ?ts)"
with * show False by simp
qed
hence "row ?E i ≠ 0⇩v (dim_col ?E)" by (simp add: length_Keys_to_list)
thus "f i < dim_col ?E"
by (simp only: row_not_zero_iff_pivot_fun[OF assms(2) ‹i < dim_row ?E›])
qed
qed
lemma phull_Macaulay_list: "phull (set (Macaulay_list ps)) = phull (set ps)"
proof -
have *: "Keys (set ps) ⊆ set (Keys_to_list ps)"
by (simp add: set_Keys_to_list)
have "phull (set (Macaulay_list ps)) =
phull (set (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps))))"
by (simp only: set_Macaulay_list phull.span_Diff_zero)
also have "... = phull (set ps)"
by (simp only: Macaulay_mat_def phull_row_echelon[OF * distinct_Keys_to_list])
finally show ?thesis .
qed
lemma pmdl_Macaulay_list: "pmdl (set (Macaulay_list ps)) = pmdl (set ps)"
proof -
have *: "Keys (set ps) ⊆ set (Keys_to_list ps)"
by (simp add: set_Keys_to_list)
have "pmdl (set (Macaulay_list ps)) =
pmdl (set (mat_to_polys (Keys_to_list ps) (row_echelon (Macaulay_mat ps))))"
by (simp only: set_Macaulay_list pmdl.span_Diff_zero)
also have "... = pmdl (set ps)"
by (simp only: Macaulay_mat_def pmdl_row_echelon[OF * distinct_Keys_to_list])
finally show ?thesis .
qed
lemma Macaulay_list_is_monic_set: "is_monic_set (set (Macaulay_list ps))"
proof (rule is_monic_setI)
let ?ts = "Keys_to_list ps"
let ?E = "row_echelon (Macaulay_mat ps)"
fix p
assume "p ∈ set (Macaulay_list ps)"
obtain h where "pivot_fun ?E h (dim_col ?E)" by (rule row_echelon_pivot_fun)
with ‹p ∈ set (Macaulay_list ps)› obtain i where "i < dim_row ?E"
and p: "p = (mat_to_polys ?ts ?E) ! i" and "h i < dim_col ?E"
by (rule in_Macaulay_listE)
show "lc p = 1" unfolding p Keys_to_list_eq_pps_to_list
by (rule lc_row_to_poly_pivot_fun, simp, fact+)
qed
lemma Macaulay_list_not_zero: "0 ∉ set (Macaulay_list ps)"
by (simp add: Macaulay_list_def)
lemma Macaulay_list_distinct_lt:
assumes "x ∈ set (Macaulay_list ps)" and "y ∈ set (Macaulay_list ps)"
and "x ≠ y"
shows "lt x ≠ lt y"
proof
let ?S = "Keys (set ps)"
let ?ts = "Keys_to_list ps"
let ?E = "row_echelon (Macaulay_mat ps)"
assume "lt x = lt y"
obtain h where pf: "pivot_fun ?E h (dim_col ?E)" by (rule row_echelon_pivot_fun)
with assms(1) obtain i1 where "i1 < dim_row ?E"
and x: "x = (mat_to_polys ?ts ?E) ! i1" and "h i1 < dim_col ?E"
by (rule in_Macaulay_listE)
from assms(2) pf obtain i2 where "i2 < dim_row ?E"
and y: "y = (mat_to_polys ?ts ?E) ! i2" and "h i2 < dim_col ?E"
by (rule in_Macaulay_listE)
have "lt x = ?ts ! (h i1)"
by (simp only: x Keys_to_list_eq_pps_to_list, rule lt_row_to_poly_pivot_fun, simp, fact+)
moreover have "lt y = ?ts ! (h i2)"
by (simp only: y Keys_to_list_eq_pps_to_list, rule lt_row_to_poly_pivot_fun, simp, fact+)
ultimately have "?ts ! (h i1) = ?ts ! (h i2)" by (simp only: ‹lt x = lt y›)
hence "pps_to_list (Keys (set ps)) ! h i1 = pps_to_list (Keys (set ps)) ! h i2"
by (simp only: Keys_to_list_eq_pps_to_list)
have "i1 = i2"
proof (rule lt_row_to_poly_pivot_fun_eqD)
show "card ?S = dim_col ?E" by simp
qed fact+
hence "x = y" by (simp only: x y)
with ‹x ≠ y› show False ..
qed
lemma Macaulay_list_lt:
assumes "p ∈ phull (set ps)" and "p ≠ 0"
obtains g where "g ∈ set (Macaulay_list ps)" and "g ≠ 0" and "lt p = lt g"
proof -
let ?S = "Keys (set ps)"
let ?ts = "Keys_to_list ps"
let ?E = "row_echelon (Macaulay_mat ps)"
let ?gs = "mat_to_polys ?ts ?E"
have "finite ?S" by (rule finite_Keys, rule)
have "?S ⊆ set ?ts" by (simp only: set_Keys_to_list)
from assms(1) ‹?S ⊆ set ?ts› have "p ∈ row_to_poly ?ts ` row_space ?E"
by (simp only: Macaulay_mat_def row_space_row_echelon_eq_phull[symmetric])
hence "p ∈ row_to_poly (pps_to_list ?S) ` row_space ?E"
by (simp only: Keys_to_list_eq_pps_to_list)
obtain f where "pivot_fun ?E f (dim_col ?E)" by (rule row_echelon_pivot_fun)
have "lt p ∈ lt_set (set ?gs)" unfolding Keys_to_list_eq_pps_to_list
by (rule lt_row_space_pivot_fun, simp, fact+)
then obtain g where "g ∈ set ?gs" and "g ≠ 0" and "lt g = lt p" by (rule lt_setE)
show ?thesis
proof
from ‹g ∈ set ?gs› ‹g ≠ 0› show "g ∈ set (Macaulay_list ps)" by (simp add: set_Macaulay_list)
next
from ‹lt g = lt p› show "lt p = lt g" by simp
qed fact
qed
end
end
Theory F4
section ‹Faug\`ere's F4 Algorithm›
theory F4
imports Macaulay_Matrix Algorithm_Schema
begin
text ‹This theory implements Faug\`ere's F4 algorithm based on @{const gd_term.gb_schema_direct}.›
subsection ‹Symbolic Preprocessing›
context gd_term
begin
definition sym_preproc_aux_term1 :: "('a ⇒ nat) ⇒ ((('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) ×
(('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list)) set"
where "sym_preproc_aux_term1 d =
{((gs1, ks1, ts1, fs1), (gs2::('t ⇒⇩0 'b) list, ks2, ts2, fs2)). ∃t2∈set ts2. ∀t1∈set ts1. t1 ≺⇩t t2}"
definition sym_preproc_aux_term2 :: "('a ⇒ nat) ⇒ ((('t ⇒⇩0 'b::zero) list × 't list × 't list × ('t ⇒⇩0 'b) list) ×
(('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list)) set"
where "sym_preproc_aux_term2 d =
{((gs1, ks1, ts1, fs1), (gs2::('t ⇒⇩0 'b) list, ks2, ts2, fs2)). gs1 = gs2 ∧
dgrad_set_le d (pp_of_term ` set ts1) (pp_of_term ` (Keys (set gs2) ∪ set ts2))}"
definition sym_preproc_aux_term
where "sym_preproc_aux_term d = sym_preproc_aux_term1 d ∩ sym_preproc_aux_term2 d"
lemma wfp_on_ord_term_strict:
assumes "dickson_grading d"
shows "wfp_on (≺⇩t) (pp_of_term -` dgrad_set d m)"
proof (rule wfp_onI_min)
fix x Q
assume "x ∈ Q" and "Q ⊆ pp_of_term -` dgrad_set d m"
from wf_dickson_less_v[OF assms, of m] ‹x ∈ Q› obtain z
where "z ∈ Q" and *: "⋀y. dickson_less_v d m y z ⟹ y ∉ Q" by (rule wfE_min[to_pred], blast)
from this(1) ‹Q ⊆ pp_of_term -` dgrad_set d m› have "z ∈ pp_of_term -` dgrad_set d m" ..
show "∃z∈Q. ∀y ∈ pp_of_term -` dgrad_set d m. y ≺⇩t z ⟶ y ∉ Q"
proof (intro bexI ballI impI, rule *)
fix y
assume "y ∈ pp_of_term -` dgrad_set d m" and "y ≺⇩t z"
from this(1) ‹z ∈ pp_of_term -` dgrad_set d m› have "d (pp_of_term y) ≤ m" and "d (pp_of_term z) ≤ m"
by (simp_all add: dgrad_set_def)
thus "dickson_less_v d m y z" using ‹y ≺⇩t z› by (rule dickson_less_vI)
qed fact
qed
lemma sym_preproc_aux_term1_wf_on:
assumes "dickson_grading d"
shows "wfp_on (λx y. (x, y) ∈ sym_preproc_aux_term1 d) {x. set (fst (snd (snd x))) ⊆ pp_of_term -` dgrad_set d m}"
proof (rule wfp_onI_min)
let ?B = "pp_of_term -` dgrad_set d m"
let ?A = "{x::(('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list). set (fst (snd (snd x))) ⊆ ?B}"
have A_sub_Pow: "set ` fst ` snd ` snd ` ?A ⊆ Pow ?B" by auto
fix x Q
assume "x ∈ Q" and "Q ⊆ ?A"
let ?Q = "{ord_term_lin.Max (set (fst (snd (snd q)))) | q. q ∈ Q ∧ fst (snd (snd q)) ≠ []}"
show "∃z∈Q. ∀y∈{x. set (fst (snd (snd x))) ⊆ ?B}. (y, z) ∈ sym_preproc_aux_term1 d ⟶ y ∉ Q"
proof (cases "∃z∈Q. fst (snd (snd z)) = []")
case True
then obtain z where "z ∈ Q" and "fst (snd (snd z)) = []" ..
show ?thesis
proof (intro bexI ballI impI)
fix y
assume "(y, z) ∈ sym_preproc_aux_term1 d"
then obtain t where "t ∈ set (fst (snd (snd z)))" unfolding sym_preproc_aux_term1_def by auto
with ‹fst (snd (snd z)) = []› show "y ∉ Q" by simp
qed fact
next
case False
hence *: "q ∈ Q ⟹ fst (snd (snd q)) ≠ []" for q by blast
with ‹x ∈ Q› have "fst (snd (snd x)) ≠ []" by simp
from assms have "wfp_on (≺⇩t) ?B" by (rule wfp_on_ord_term_strict)
moreover from ‹x ∈ Q› ‹fst (snd (snd x)) ≠ []›
have "ord_term_lin.Max (set (fst (snd (snd x)))) ∈ ?Q" by blast
moreover have "?Q ⊆ ?B"
proof (rule, simp, elim exE conjE, simp)
fix a b c d0
assume "(a, b, c, d0) ∈ Q" and "c ≠ []"
from this(1) ‹Q ⊆ ?A› have "(a, b, c, d0) ∈ ?A" ..
hence "pp_of_term ` set c ⊆ dgrad_set d m" by auto
moreover have "pp_of_term (ord_term_lin.Max (set c)) ∈ pp_of_term ` set c"
proof
from ‹c ≠ []› show "ord_term_lin.Max (set c) ∈ set c" by simp
qed (fact refl)
ultimately show "pp_of_term (ord_term_lin.Max (set c)) ∈ dgrad_set d m" ..
qed
ultimately obtain t where "t ∈ ?Q" and min: "⋀s. s ≺⇩t t ⟹ s ∉ ?Q" by (rule wfp_onE_min) blast
from this(1) obtain z where "z ∈ Q" and "fst (snd (snd z)) ≠ []"
and t: "t = ord_term_lin.Max (set (fst (snd (snd z))))" by blast
show ?thesis
proof (intro bexI ballI impI, rule)
fix y
assume "y ∈ ?A" and "(y, z) ∈ sym_preproc_aux_term1 d" and "y ∈ Q"
from this(2) obtain t' where "t' ∈ set (fst (snd (snd z)))"
and **: "⋀s. s ∈ set (fst (snd (snd y))) ⟹ s ≺⇩t t'"
unfolding sym_preproc_aux_term1_def by auto
from ‹y ∈ Q› have "fst (snd (snd y)) ≠ []" by (rule *)
with ‹y ∈ Q› have "ord_term_lin.Max (set (fst (snd (snd y)))) ∈ ?Q" (is "?s ∈ _")
by blast
from ‹fst (snd (snd y)) ≠ []› have "?s ∈ set (fst (snd (snd y)))" by simp
hence "?s ≺⇩t t'" by (rule **)
also from ‹t' ∈ set (fst (snd (snd z)))› have "t' ≼⇩t t" unfolding t
using ‹fst (snd (snd z)) ≠ []› by simp
finally have "?s ∉ ?Q" by (rule min)
from this ‹?s ∈ ?Q› show False ..
qed fact
qed
qed
lemma sym_preproc_aux_term_wf:
assumes "dickson_grading d"
shows "wf (sym_preproc_aux_term d)"
proof (rule wfI_min)
fix x::"(('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list)" and Q
assume "x ∈ Q"
let ?A = "Keys (set (fst x)) ∪ set (fst (snd (snd x)))"
have "finite ?A" by (simp add: finite_Keys)
hence "finite (pp_of_term ` ?A)" by (rule finite_imageI)
then obtain m where "pp_of_term ` ?A ⊆ dgrad_set d m" by (rule dgrad_set_exhaust)
hence A: "?A ⊆ pp_of_term -` dgrad_set d m" by blast
let ?B = "pp_of_term -` dgrad_set d m"
let ?Q = "{q ∈ Q. Keys (set (fst q)) ∪ set (fst (snd (snd q))) ⊆ ?B}"
from assms have "wfp_on (λx y. (x, y) ∈ sym_preproc_aux_term1 d) {x. set (fst (snd (snd x))) ⊆ ?B}"
by (rule sym_preproc_aux_term1_wf_on)
moreover from ‹x ∈ Q› A have "x ∈ ?Q" by simp
moreover have "?Q ⊆ {x. set (fst (snd (snd x))) ⊆ ?B}" by auto
ultimately obtain z where "z ∈ ?Q"
and *: "⋀y. (y, z) ∈ sym_preproc_aux_term1 d ⟹ y ∉ ?Q" by (rule wfp_onE_min) blast
from this(1) have "z ∈ Q" and "Keys (set (fst z)) ∪ set (fst (snd (snd z))) ⊆ ?B" by simp_all
from this(2) have a: "pp_of_term ` (Keys (set (fst z)) ∪ set (fst (snd (snd z)))) ⊆ dgrad_set d m"
by blast
show "∃z∈Q. ∀y. (y, z) ∈ sym_preproc_aux_term d ⟶ y ∉ Q"
proof (intro bexI allI impI)
fix y
assume "(y, z) ∈ sym_preproc_aux_term d"
hence "(y, z) ∈ sym_preproc_aux_term1 d" and "(y, z) ∈ sym_preproc_aux_term2 d"
by (simp_all add: sym_preproc_aux_term_def)
from this(2) have "fst y = fst z"
and "dgrad_set_le d (pp_of_term ` set (fst (snd (snd y)))) (pp_of_term ` (Keys (set (fst z)) ∪ set (fst (snd (snd z)))))"
by (auto simp add: sym_preproc_aux_term2_def)
from this(2) a have "pp_of_term ` (set (fst (snd (snd y)))) ⊆ dgrad_set d m"
by (rule dgrad_set_le_dgrad_set)
hence "Keys (set (fst y)) ∪ set (fst (snd (snd y))) ⊆ ?B"
using a by (auto simp add: ‹fst y = fst z›)
moreover from ‹(y, z) ∈ sym_preproc_aux_term1 d› have "y ∉ ?Q" by (rule *)
ultimately show "y ∉ Q" by simp
qed fact
qed
primrec sym_preproc_addnew :: "('t ⇒⇩0 'b::semiring_1) list ⇒ 't list ⇒ ('t ⇒⇩0 'b) list ⇒ 't ⇒
('t list × ('t ⇒⇩0 'b) list)" where
"sym_preproc_addnew [] vs fs _ = (vs, fs)"|
"sym_preproc_addnew (g # gs) vs fs v =
(if lt g adds⇩t v then
(let f = monom_mult 1 (pp_of_term v - lp g) g in
sym_preproc_addnew gs (merge_wrt (≻⇩t) vs (keys_to_list (tail f))) (insert_list f fs) v
)
else
sym_preproc_addnew gs vs fs v
)"
lemma fst_sym_preproc_addnew_less:
assumes "⋀u. u ∈ set vs ⟹ u ≺⇩t v"
and "u ∈ set (fst (sym_preproc_addnew gs vs fs v))"
shows "u ≺⇩t v"
using assms
proof (induct gs arbitrary: fs vs)
case Nil
from Nil(2) have "u ∈ set vs" by simp
thus ?case by (rule Nil(1))
next
case (Cons g gs)
from Cons(3) show ?case
proof (simp add: Let_def split: if_splits)
let ?t = "pp_of_term v - lp g"
assume "lt g adds⇩t v"
assume "u ∈ set (fst (sym_preproc_addnew gs
(merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g))))
(insert_list (monom_mult 1 ?t g) fs) v))"
with _ show ?thesis
proof (rule Cons(1))
fix u
assume "u ∈ set (merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g))))"
hence "u ∈ set vs ∨ u ∈ keys (tail (monom_mult 1 ?t g))"
by (simp add: set_merge_wrt keys_to_list_def set_pps_to_list)
thus "u ≺⇩t v"
proof
assume "u ∈ set vs"
thus ?thesis by (rule Cons(2))
next
assume "u ∈ keys (tail (monom_mult 1 ?t g))"
hence "u ≺⇩t lt (monom_mult 1 ?t g)" by (rule keys_tail_less_lt)
also have "... ≼⇩t ?t ⊕ lt g" by (rule lt_monom_mult_le)
also from ‹lt g adds⇩t v› have "... = v"
by (metis add_diff_cancel_right' adds_termE pp_of_term_splus)
finally show ?thesis .
qed
qed
next
assume "u ∈ set (fst (sym_preproc_addnew gs vs fs v))"
with Cons(2) show ?thesis by (rule Cons(1))
qed
qed
lemma fst_sym_preproc_addnew_dgrad_set_le:
assumes "dickson_grading d"
shows "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs vs fs v))) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs)))"
proof (induct gs arbitrary: fs vs)
case Nil
show ?case by (auto intro: dgrad_set_le_subset)
next
case (Cons g gs)
show ?case
proof (simp add: Let_def, intro conjI impI)
assume "lt g adds⇩t v"
let ?t = "pp_of_term v - lp g"
let ?vs = "merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g)))"
let ?fs = "insert_list (monom_mult 1 ?t g) fs"
from Cons have "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs ?vs ?fs v)))
(pp_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs)))"
proof (rule dgrad_set_le_trans)
show "dgrad_set_le d (pp_of_term ` (Keys (set gs) ∪ insert v (set ?vs)))
(pp_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs)))"
unfolding dgrad_set_le_def set_merge_wrt set_keys_to_list
proof (intro ballI)
fix s
assume "s ∈ pp_of_term ` (Keys (set gs) ∪ insert v (set vs ∪ keys (tail (monom_mult 1 ?t g))))"
hence "s ∈ pp_of_term ` (Keys (set gs) ∪ insert v (set vs)) ∪ pp_of_term ` keys (tail (monom_mult 1 ?t g))"
by auto
thus "∃t ∈ pp_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs)). d s ≤ d t"
proof
assume "s ∈ pp_of_term ` (Keys (set gs) ∪ insert v (set vs))"
thus ?thesis by (auto simp add: Keys_insert)
next
assume "s ∈ pp_of_term ` keys (tail (monom_mult 1 ?t g))"
hence "s ∈ pp_of_term ` keys (monom_mult 1 ?t g)" by (auto simp add: keys_tail)
from this keys_monom_mult_subset have "s ∈ pp_of_term ` (⊕) ?t ` keys g" by blast
then obtain u where "u ∈ keys g" and s: "s = pp_of_term (?t ⊕ u)" by blast
have "d s = d ?t ∨ d s = d (pp_of_term u)" unfolding s pp_of_term_splus
using dickson_gradingD1[OF assms] by auto
thus ?thesis
proof
from ‹lt g adds⇩t v› have "lp g adds pp_of_term v" by (simp add: adds_term_def)
assume "d s = d ?t"
also from assms ‹lp g adds pp_of_term v› have "... ≤ d (pp_of_term v)"
by (rule dickson_grading_minus)
finally show ?thesis by blast
next
assume "d s = d (pp_of_term u)"
moreover from ‹u ∈ keys g› have "u ∈ Keys (insert g (set gs))" by (simp add: Keys_insert)
ultimately show ?thesis by auto
qed
qed
qed
qed
thus "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs ?vs ?fs v)))
(insert (pp_of_term v) (pp_of_term ` (Keys (insert g (set gs)) ∪ set vs)))"
by simp
next
from Cons show "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs vs fs v)))
(insert (pp_of_term v) (pp_of_term ` (Keys (insert g (set gs)) ∪ set vs)))"
proof (rule dgrad_set_le_trans)
show "dgrad_set_le d (pp_of_term ` (Keys (set gs) ∪ insert v (set vs)))
(insert (pp_of_term v) (pp_of_term ` (Keys (insert g (set gs)) ∪ set vs)))"
by (rule dgrad_set_le_subset, auto simp add: Keys_def)
qed
qed
qed
lemma components_fst_sym_preproc_addnew_subset:
"component_of_term ` set (fst (sym_preproc_addnew gs vs fs v)) ⊆ component_of_term ` (Keys (set gs) ∪ insert v (set vs))"
proof (induct gs arbitrary: fs vs)
case Nil
show ?case by (auto intro: dgrad_set_le_subset)
next
case (Cons g gs)
show ?case
proof (simp add: Let_def, intro conjI impI)
assume "lt g adds⇩t v"
let ?t = "pp_of_term v - lp g"
let ?vs = "merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g)))"
let ?fs = "insert_list (monom_mult 1 ?t g) fs"
from Cons have "component_of_term ` set (fst (sym_preproc_addnew gs ?vs ?fs v)) ⊆
component_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs))"
proof (rule subset_trans)
show "component_of_term ` (Keys (set gs) ∪ insert v (set ?vs)) ⊆
component_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs))"
unfolding set_merge_wrt set_keys_to_list
proof
fix k
assume "k ∈ component_of_term ` (Keys (set gs) ∪ insert v (set vs ∪ keys (tail (monom_mult 1 ?t g))))"
hence "k ∈ component_of_term ` (Keys (set gs) ∪ insert v (set vs)) ∪ component_of_term ` keys (tail (monom_mult 1 ?t g))"
by auto
thus "k ∈ component_of_term ` (Keys (insert g (set gs)) ∪ insert v (set vs))"
proof
assume "k ∈ component_of_term ` (Keys (set gs) ∪ insert v (set vs))"
thus ?thesis by (auto simp add: Keys_insert)
next
assume "k ∈ component_of_term ` keys (tail (monom_mult 1 ?t g))"
hence "k ∈ component_of_term ` keys (monom_mult 1 ?t g)" by (auto simp add: keys_tail)
from this keys_monom_mult_subset have "k ∈ component_of_term ` (⊕) ?t ` keys g" by blast
also have "... ⊆ component_of_term ` keys g" using component_of_term_splus by fastforce
finally show ?thesis by (simp add: image_Un Keys_insert)
qed
qed
qed
thus "component_of_term ` set (fst (sym_preproc_addnew gs ?vs ?fs v)) ⊆
insert (component_of_term v) (component_of_term ` (Keys (insert g (set gs)) ∪ set vs))"
by simp
next
from Cons show "component_of_term ` set (fst (sym_preproc_addnew gs vs fs v)) ⊆
insert (component_of_term v) (component_of_term ` (Keys (insert g (set gs)) ∪ set vs))"
proof (rule subset_trans)
show "component_of_term ` (Keys (set gs) ∪ insert v (set vs)) ⊆
insert (component_of_term v) (component_of_term ` (Keys (insert g (set gs)) ∪ set vs))"
by (auto simp add: Keys_def)
qed
qed
qed
lemma fst_sym_preproc_addnew_superset: "set vs ⊆ set (fst (sym_preproc_addnew gs vs fs v))"
proof (induct gs arbitrary: vs fs)
case Nil
show ?case by simp
next
case (Cons g gs)
show ?case
proof (simp add: Let_def, intro conjI impI)
let ?t = "pp_of_term v - lp g"
define f where "f = monom_mult 1 ?t g"
have "set vs ⊆ set (merge_wrt (≻⇩t) vs (keys_to_list (tail f)))" by (auto simp add: set_merge_wrt)
thus "set vs ⊆ set (fst (sym_preproc_addnew gs
(merge_wrt (≻⇩t) vs (keys_to_list (tail f))) (insert_list f fs) v))"
using Cons by (rule subset_trans)
next
show "set vs ⊆ set (fst (sym_preproc_addnew gs vs fs v))" by (fact Cons)
qed
qed
lemma snd_sym_preproc_addnew_superset: "set fs ⊆ set (snd (sym_preproc_addnew gs vs fs v))"
proof (induct gs arbitrary: vs fs)
case Nil
show ?case by simp
next
case (Cons g gs)
show ?case
proof (simp add: Let_def, intro conjI impI)
let ?t = "pp_of_term v - lp g"
define f where "f = monom_mult 1 ?t g"
have "set fs ⊆ set (insert_list f fs)" by (auto simp add: set_insert_list)
thus "set fs ⊆ set (snd (sym_preproc_addnew gs
(merge_wrt (≻⇩t) vs (keys_to_list (tail f))) (insert_list f fs) v))"
using Cons by (rule subset_trans)
next
show "set fs ⊆ set (snd (sym_preproc_addnew gs vs fs v))" by (fact Cons)
qed
qed
lemma in_snd_sym_preproc_addnewE:
assumes "p ∈ set (snd (sym_preproc_addnew gs vs fs v))"
assumes 1: "p ∈ set fs ⟹ thesis"
assumes 2: "⋀g s. g ∈ set gs ⟹ p = monom_mult 1 s g ⟹ thesis"
shows thesis
using assms
proof (induct gs arbitrary: vs fs thesis)
case Nil
from Nil(1) have "p ∈ set fs" by simp
thus ?case by (rule Nil(2))
next
case (Cons g gs)
from Cons(2) show ?case
proof (simp add: Let_def split: if_splits)
define f where "f = monom_mult 1 (pp_of_term v - lp g) g"
define ts' where "ts' = merge_wrt (≻⇩t) vs (keys_to_list (tail f))"
define fs' where "fs' = insert_list f fs"
assume "p ∈ set (snd (sym_preproc_addnew gs ts' fs' v))"
thus ?thesis
proof (rule Cons(1))
assume "p ∈ set fs'"
hence "p = f ∨ p ∈ set fs" by (simp add: fs'_def set_insert_list)
thus ?thesis
proof
assume "p = f"
have "g ∈ set (g # gs)" by simp
from this ‹p = f› show ?thesis unfolding f_def by (rule Cons(4))
next
assume "p ∈ set fs"
thus ?thesis by (rule Cons(3))
qed
next
fix h s
assume "h ∈ set gs"
hence "h ∈ set (g # gs)" by simp
moreover assume "p = monom_mult 1 s h"
ultimately show thesis by (rule Cons(4))
qed
next
assume "p ∈ set (snd (sym_preproc_addnew gs vs fs v))"
moreover note Cons(3)
moreover have "h ∈ set gs ⟹ p = monom_mult 1 s h ⟹ thesis" for h s
proof -
assume "h ∈ set gs"
hence "h ∈ set (g # gs)" by simp
moreover assume "p = monom_mult 1 s h"
ultimately show thesis by (rule Cons(4))
qed
ultimately show ?thesis by (rule Cons(1))
qed
qed
lemma sym_preproc_addnew_pmdl:
"pmdl (set gs ∪ set (snd (sym_preproc_addnew gs vs fs v))) = pmdl (set gs ∪ set fs)"
(is "pmdl (set gs ∪ ?l) = ?r")
proof
have "set gs ⊆ set gs ∪ set fs" by simp
also have "... ⊆ ?r" by (fact pmdl.span_superset)
finally have "set gs ⊆ ?r" .
moreover have "?l ⊆ ?r"
proof
fix p
assume "p ∈ ?l"
thus "p ∈ ?r"
proof (rule in_snd_sym_preproc_addnewE)
assume "p ∈ set fs"
hence "p ∈ set gs ∪ set fs" by simp
thus ?thesis by (rule pmdl.span_base)
next
fix g s
assume "g ∈ set gs" and p: "p = monom_mult 1 s g"
from this(1) ‹set gs ⊆ ?r› have "g ∈ ?r" ..
thus ?thesis unfolding p by (rule pmdl_closed_monom_mult)
qed
qed
ultimately have "set gs ∪ ?l ⊆ ?r" by blast
thus "pmdl (set gs ∪ ?l) ⊆ ?r" by (rule pmdl.span_subset_spanI)
next
from snd_sym_preproc_addnew_superset have "set gs ∪ set fs ⊆ set gs ∪ ?l" by blast
thus "?r ⊆ pmdl (set gs ∪ ?l)" by (rule pmdl.span_mono)
qed
lemma Keys_snd_sym_preproc_addnew:
"Keys (set (snd (sym_preproc_addnew gs vs fs v))) ∪ insert v (set vs) =
Keys (set fs) ∪ insert v (set (fst (sym_preproc_addnew gs vs (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list) v)))"
proof (induct gs arbitrary: vs fs)
case Nil
show ?case by simp
next
case (Cons g gs)
from Cons have eq: "insert v (Keys (set (snd (sym_preproc_addnew gs ts' fs' v))) ∪ set ts') =
insert v (Keys (set fs') ∪ set (fst (sym_preproc_addnew gs ts' fs' v)))"
for ts' fs' by simp
show ?case
proof (simp add: Let_def eq, rule)
assume "lt g adds⇩t v"
let ?t = "pp_of_term v - lp g"
define f where "f = monom_mult 1 ?t g"
define ts' where "ts' = merge_wrt (≻⇩t) vs (keys_to_list (tail f))"
define fs' where "fs' = insert_list f fs"
have "keys (tail f) = keys f - {v}"
proof (cases "g = 0")
case True
hence "f = 0" by (simp add: f_def)
thus ?thesis by simp
next
case False
hence "lt f = ?t ⊕ lt g" by (simp add: f_def lt_monom_mult)
also from ‹lt g adds⇩t v› have "... = v"
by (metis add_diff_cancel_right' adds_termE pp_of_term_splus)
finally show ?thesis by (simp add: keys_tail)
qed
hence ts': "set ts' = set vs ∪ (keys f - {v})"
by (simp add: ts'_def set_merge_wrt set_keys_to_list)
have fs': "set fs' = insert f (set fs)" by (simp add: fs'_def set_insert_list)
hence "f ∈ set fs'" by simp
from this snd_sym_preproc_addnew_superset have "f ∈ set (snd (sym_preproc_addnew gs ts' fs' v))" ..
hence "keys f ⊆ Keys (set (snd (sym_preproc_addnew gs ts' fs' v)))" by (rule keys_subset_Keys)
hence "insert v (Keys (set (snd (sym_preproc_addnew gs ts' fs' v))) ∪ set vs) =
insert v (Keys (set (snd (sym_preproc_addnew gs ts' fs' v))) ∪ set ts')"
by (auto simp add: ts')
also have "... = insert v (Keys (set fs') ∪ set (fst (sym_preproc_addnew gs ts' fs' v)))"
by (fact eq)
also have "... = insert v (Keys (set fs) ∪ set (fst (sym_preproc_addnew gs ts' fs' v)))"
proof -
{
fix u
assume "u ≠ v" and "u ∈ keys f"
hence "u ∈ set ts'" by (simp add: ts')
from this fst_sym_preproc_addnew_superset have "u ∈ set (fst (sym_preproc_addnew gs ts' fs' v))" ..
}
thus ?thesis by (auto simp add: fs' Keys_insert)
qed
finally show "insert v (Keys (set (snd (sym_preproc_addnew gs ts' fs' v))) ∪ set vs) =
insert v (Keys (set fs) ∪ set (fst (sym_preproc_addnew gs ts' fs' v)))" .
qed
qed
lemma sym_preproc_addnew_complete:
assumes "g ∈ set gs" and "lt g adds⇩t v"
shows "monom_mult 1 (pp_of_term v - lp g) g ∈ set (snd (sym_preproc_addnew gs vs fs v))"
using assms(1)
proof (induct gs arbitrary: vs fs)
case Nil
thus ?case by simp
next
case (Cons h gs)
let ?t = "pp_of_term v - lp g"
show ?case
proof (cases "h = g")
case True
show ?thesis
proof (simp add: True assms(2) Let_def)
define f where "f = monom_mult 1 ?t g"
define ts' where "ts' = merge_wrt (≻⇩t) vs (keys_to_list (tail (monom_mult 1 ?t g)))"
have "f ∈ set (insert_list f fs)" by (simp add: set_insert_list)
with snd_sym_preproc_addnew_superset show "f ∈ set (snd (sym_preproc_addnew gs ts' (insert_list f fs) v))" ..
qed
next
case False
with Cons(2) have "g ∈ set gs" by simp
hence *: "monom_mult 1 ?t g ∈ set (snd (sym_preproc_addnew gs ts' fs' v))" for ts' fs'
by (rule Cons(1))
show ?thesis by (simp add: Let_def *)
qed
qed
function sym_preproc_aux :: "('t ⇒⇩0 'b::semiring_1) list ⇒ 't list ⇒ ('t list × ('t ⇒⇩0 'b) list) ⇒
('t list × ('t ⇒⇩0 'b) list)" where
"sym_preproc_aux gs ks (vs, fs) =
(if vs = [] then
(ks, fs)
else
let v = ord_term_lin.max_list vs; vs' = removeAll v vs in
sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs' fs v)
)"
by pat_completeness auto
termination proof -
from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" ..
let ?R = "(sym_preproc_aux_term d)::((('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) ×
('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) set"
show ?thesis
proof
from dg show "wf ?R" by (rule sym_preproc_aux_term_wf)
next
fix gs::"('t ⇒⇩0 'b) list" and ks vs fs v vs'
assume "vs ≠ []" and "v = ord_term_lin.max_list vs" and vs': "vs' = removeAll v vs"
from this(1, 2) have v: "v = ord_term_lin.Max (set vs)"
by (simp add: ord_term_lin.max_list_Max)
obtain vs0 fs0 where eq: "sym_preproc_addnew gs vs' fs v = (vs0, fs0)" by fastforce
show "((gs, ks @ [v], sym_preproc_addnew gs vs' fs v), (gs, ks, vs, fs)) ∈ ?R"
proof (simp add: eq sym_preproc_aux_term_def sym_preproc_aux_term1_def sym_preproc_aux_term2_def,
intro conjI bexI ballI)
fix w
assume "w ∈ set vs0"
show "w ≺⇩t v"
proof (rule fst_sym_preproc_addnew_less)
fix u
assume "u ∈ set vs'"
thus "u ≺⇩t v" unfolding vs' v set_removeAll using ord_term_lin.antisym_conv1 by fastforce
next
from ‹w ∈ set vs0› show "w ∈ set (fst (sym_preproc_addnew gs vs' fs v))" by (simp add: eq)
qed
next
from ‹vs ≠ []› show "v ∈ set vs" by (simp add: v)
next
from dg have "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs vs' fs v)))
(pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))"
by (rule fst_sym_preproc_addnew_dgrad_set_le)
moreover have "insert v (set vs') = set vs" by (auto simp add: vs' v ‹vs ≠ []›)
ultimately show "dgrad_set_le d (pp_of_term ` set vs0) (pp_of_term ` (Keys (set gs) ∪ set vs))"
by (simp add: eq)
qed
qed
qed
lemma sym_preproc_aux_Nil: "sym_preproc_aux gs ks ([], fs) = (ks, fs)"
by simp
lemma sym_preproc_aux_sorted:
assumes "sorted_wrt (≻⇩t) (v # vs)"
shows "sym_preproc_aux gs ks (v # vs, fs) = sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs fs v)"
proof -
from assms have *: "u ∈ set vs ⟹ u ≺⇩t v" for u by simp
have "ord_term_lin.max_list (v # vs) = ord_term_lin.Max (set (v # vs))"
by (simp add: ord_term_lin.max_list_Max del: ord_term_lin.max_list.simps)
also have "... = v"
proof (rule ord_term_lin.Max_eqI)
fix s
assume "s ∈ set (v # vs)"
hence "s = v ∨ s ∈ set vs" by simp
thus "s ≼⇩t v"
proof
assume "s = v"
thus ?thesis by simp
next
assume "s ∈ set vs"
hence "s ≺⇩t v" by (rule *)
thus ?thesis by simp
qed
next
show "v ∈ set (v # vs)" by simp
qed rule
finally have eq1: "ord_term_lin.max_list (v # vs) = v" .
have eq2: "removeAll v (v # vs) = vs"
proof (simp, rule removeAll_id, rule)
assume "v ∈ set vs"
hence "v ≺⇩t v" by (rule *)
thus False ..
qed
show ?thesis by (simp only: sym_preproc_aux.simps eq1 eq2 Let_def, simp)
qed
lemma sym_preproc_aux_induct [consumes 0, case_names base rec]:
assumes base: "⋀ks fs. P ks [] fs (ks, fs)"
and rec: "⋀ks vs fs v vs'. vs ≠ [] ⟹ v = ord_term_lin.Max (set vs) ⟹ vs' = removeAll v vs ⟹
P (ks @ [v]) (fst (sym_preproc_addnew gs vs' fs v)) (snd (sym_preproc_addnew gs vs' fs v))
(sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs' fs v)) ⟹
P ks vs fs (sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs' fs v))"
shows "P ks vs fs (sym_preproc_aux gs ks (vs, fs))"
proof -
from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" ..
let ?R = "(sym_preproc_aux_term d)::((('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) ×
('t ⇒⇩0 'b) list × 't list × 't list × ('t ⇒⇩0 'b) list) set"
define args where "args = (gs, ks, vs, fs)"
from dg have "wf ?R" by (rule sym_preproc_aux_term_wf)
hence "fst args = gs ⟹ P (fst (snd args)) (fst (snd (snd args))) (snd (snd (snd args)))
(sym_preproc_aux gs (fst (snd args)) (snd (snd args)))"
proof induct
fix x
assume IH': "⋀y. (y, x) ∈ sym_preproc_aux_term d ⟹ fst y = gs ⟹
P (fst (snd y)) (fst (snd (snd y))) (snd (snd (snd y)))
(sym_preproc_aux gs (fst (snd y)) (snd (snd y)))"
assume "fst x = gs"
then obtain x0 where x: "x = (gs, x0)" by (meson eq_fst_iff)
obtain ks x1 where x0: "x0 = (ks, x1)" by (meson case_prodE case_prodI2)
obtain vs fs where x1: "x1 = (vs, fs)" by (meson case_prodE case_prodI2)
from IH' have IH: "⋀ks' n. ((gs, ks', n), (gs, ks, vs, fs)) ∈ sym_preproc_aux_term d ⟹
P ks' (fst n) (snd n) (sym_preproc_aux gs ks' n)"
unfolding x x0 x1 by fastforce
show "P (fst (snd x)) (fst (snd (snd x))) (snd (snd (snd x)))
(sym_preproc_aux gs (fst (snd x)) (snd (snd x)))"
proof (simp add: x x0 x1 Let_def, intro conjI impI)
show "P ks [] fs (ks, fs)" by (fact base)
next
assume "vs ≠ []"
define v where "v = ord_term_lin.max_list vs"
from ‹vs ≠ []› have v_alt: "v = ord_term_lin.Max (set vs)" unfolding v_def
by (rule ord_term_lin.max_list_Max)
define vs' where "vs' = removeAll v vs"
show "P ks vs fs (sym_preproc_aux gs (ks @ [v]) (sym_preproc_addnew gs vs' fs v))"
proof (rule rec, fact ‹vs ≠ []›, fact v_alt, fact vs'_def)
let ?n = "sym_preproc_addnew gs vs' fs v"
obtain vs0 fs0 where eq: "?n = (vs0, fs0)" by fastforce
show "P (ks @ [v]) (fst ?n) (snd ?n) (sym_preproc_aux gs (ks @ [v]) ?n)"
proof (rule IH,
simp add: eq sym_preproc_aux_term_def sym_preproc_aux_term1_def sym_preproc_aux_term2_def,
intro conjI bexI ballI)
fix s
assume "s ∈ set vs0"
show "s ≺⇩t v"
proof (rule fst_sym_preproc_addnew_less)
fix u
assume "u ∈ set vs'"
thus "u ≺⇩t v" unfolding vs'_def v_alt set_removeAll using ord_term_lin.antisym_conv1
by fastforce
next
from ‹s ∈ set vs0› show "s ∈ set (fst (sym_preproc_addnew gs vs' fs v))" by (simp add: eq)
qed
next
from ‹vs ≠ []› show "v ∈ set vs" by (simp add: v_alt)
next
from dg have "dgrad_set_le d (pp_of_term ` set (fst (sym_preproc_addnew gs vs' fs v)))
(pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))"
by (rule fst_sym_preproc_addnew_dgrad_set_le)
moreover have "insert v (set vs') = set vs" by (auto simp add: vs'_def v_alt ‹vs ≠ []›)
ultimately show "dgrad_set_le d (pp_of_term ` set vs0) (pp_of_term ` (Keys (set gs) ∪ set vs))"
by (simp add: eq)
qed
qed
qed
qed
thus ?thesis by (simp add: args_def)
qed
lemma fst_sym_preproc_aux_sorted_wrt:
assumes "sorted_wrt (≻⇩t) ks" and "⋀k v. k ∈ set ks ⟹ v ∈ set vs ⟹ v ≺⇩t k"
shows "sorted_wrt (≻⇩t) (fst (sym_preproc_aux gs ks (vs, fs)))"
using assms
proof (induct gs ks vs fs rule: sym_preproc_aux_induct)
case (base ks fs)
from base(1) show ?case by simp
next
case (rec ks vs fs v vs')
from rec(1) have "v ∈ set vs" by (simp add: rec(2))
from rec(1) have *: "⋀u. u ∈ set vs' ⟹ u ≺⇩t v" unfolding rec(2, 3) set_removeAll
using ord_term_lin.antisym_conv3 by force
show ?case
proof (rule rec(4))
show "sorted_wrt (≻⇩t) (ks @ [v])"
proof (simp add: sorted_wrt_append rec(5), rule)
fix k
assume "k ∈ set ks"
from this ‹v ∈ set vs› show "v ≺⇩t k" by (rule rec(6))
qed
next
fix k u
assume "k ∈ set (ks @ [v])" and "u ∈ set (fst (sym_preproc_addnew gs vs' fs v))"
from * this(2) have "u ≺⇩t v" by (rule fst_sym_preproc_addnew_less)
from ‹k ∈ set (ks @ [v])› have "k ∈ set ks ∨ k = v" by auto
thus "u ≺⇩t k"
proof
assume "k ∈ set ks"
from this ‹v ∈ set vs› have "v ≺⇩t k" by (rule rec(6))
with ‹u ≺⇩t v› show ?thesis by simp
next
assume "k = v"
with ‹u ≺⇩t v› show ?thesis by simp
qed
qed
qed
lemma fst_sym_preproc_aux_complete:
assumes "Keys (set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list)) = set ks ∪ set vs"
shows "set (fst (sym_preproc_aux gs ks (vs, fs))) = Keys (set (snd (sym_preproc_aux gs ks (vs, fs))))"
using assms
proof (induct gs ks vs fs rule: sym_preproc_aux_induct)
case (base ks fs)
thus ?case by simp
next
case (rec ks vs fs v vs')
from rec(1) have "v ∈ set vs" by (simp add: rec(2))
hence eq: "insert v (set vs') = set vs" by (auto simp add: rec(3))
also from rec(5) have "... ⊆ Keys (set fs)" by simp
also from snd_sym_preproc_addnew_superset have "... ⊆ Keys (set (snd (sym_preproc_addnew gs vs' fs v)))"
by (rule Keys_mono)
finally have "... = ... ∪ (insert v (set vs'))" by blast
also have "... = Keys (set fs) ∪ insert v (set (fst (sym_preproc_addnew gs vs' fs v)))"
by (fact Keys_snd_sym_preproc_addnew)
also have "... = (set ks ∪ (insert v (set vs'))) ∪ (insert v (set (fst (sym_preproc_addnew gs vs' fs v))))"
by (simp only: rec(5) eq)
also have "... = set (ks @ [v]) ∪ (set vs' ∪ set (fst (sym_preproc_addnew gs vs' fs v)))" by auto
also from fst_sym_preproc_addnew_superset have "... = set (ks @ [v]) ∪ set (fst (sym_preproc_addnew gs vs' fs v))"
by blast
finally show ?case by (rule rec(4))
qed
lemma snd_sym_preproc_aux_superset: "set fs ⊆ set (snd (sym_preproc_aux gs ks (vs, fs)))"
proof (induct fs rule: sym_preproc_aux_induct)
case (base ks fs)
show ?case by simp
next
case (rec ks vs fs v vs')
from snd_sym_preproc_addnew_superset rec(4) show ?case by (rule subset_trans)
qed
lemma in_snd_sym_preproc_auxE:
assumes "p ∈ set (snd (sym_preproc_aux gs ks (vs, fs)))"
assumes 1: "p ∈ set fs ⟹ thesis"
assumes 2: "⋀g t. g ∈ set gs ⟹ p = monom_mult 1 t g ⟹ thesis"
shows thesis
using assms
proof (induct gs ks vs fs arbitrary: thesis rule: sym_preproc_aux_induct)
case (base ks fs)
from base(1) have "p ∈ set fs" by simp
thus ?case by (rule base(2))
next
case (rec ks vs fs v vs')
from rec(5) show ?case
proof (rule rec(4))
assume "p ∈ set (snd (sym_preproc_addnew gs vs' fs v))"
thus ?thesis
proof (rule in_snd_sym_preproc_addnewE)
assume "p ∈ set fs"
thus ?thesis by (rule rec(6))
next
fix g s
assume "g ∈ set gs" and "p = monom_mult 1 s g"
thus ?thesis by (rule rec(7))
qed
next
fix g t
assume "g ∈ set gs" and "p = monom_mult 1 t g"
thus ?thesis by (rule rec(7))
qed
qed
lemma snd_sym_preproc_aux_pmdl:
"pmdl (set gs ∪ set (snd (sym_preproc_aux gs ks (ts, fs)))) = pmdl (set gs ∪ set fs)"
proof (induct fs rule: sym_preproc_aux_induct)
case (base ks fs)
show ?case by simp
next
case (rec ks vs fs v vs')
from rec(4) sym_preproc_addnew_pmdl show ?case by (rule trans)
qed
lemma snd_sym_preproc_aux_dgrad_set_le:
assumes "dickson_grading d" and "set vs ⊆ Keys (set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list))"
shows "dgrad_set_le d (pp_of_term ` Keys (set (snd (sym_preproc_aux gs ks (vs, fs))))) (pp_of_term ` Keys (set gs ∪ set fs))"
using assms(2)
proof (induct fs rule: sym_preproc_aux_induct)
case (base ks fs)
show ?case by (rule dgrad_set_le_subset, simp add: Keys_Un image_Un)
next
case (rec ks vs fs v vs')
let ?n = "sym_preproc_addnew gs vs' fs v"
from rec(1) have "v ∈ set vs" by (simp add: rec(2))
hence set_vs: "insert v (set vs') = set vs" by (auto simp add: rec(3))
from rec(5) have eq: "Keys (set fs) ∪ (Keys (set gs) ∪ set vs) = Keys (set gs) ∪ Keys (set fs)"
by blast
have "dgrad_set_le d (pp_of_term ` Keys (set (snd (sym_preproc_aux gs (ks @ [v]) ?n))))
(pp_of_term ` Keys (set gs ∪ set (snd ?n)))"
proof (rule rec(4))
have "set (fst ?n) ⊆ Keys (set (snd ?n)) ∪ insert v (set vs')"
by (simp only: Keys_snd_sym_preproc_addnew, blast)
also have "... = Keys (set (snd ?n)) ∪ (set vs)" by (simp only: set_vs)
also have "... ⊆ Keys (set (snd ?n))"
proof -
{
fix u
assume "u ∈ set vs"
with rec(5) have "u ∈ Keys (set fs)" ..
then obtain f where "f ∈ set fs" and "u ∈ keys f" by (rule in_KeysE)
from this(1) snd_sym_preproc_addnew_superset have "f ∈ set (snd ?n)" ..
with ‹u ∈ keys f› have "u ∈ Keys (set (snd ?n))" by (rule in_KeysI)
}
thus ?thesis by auto
qed
finally show "set (fst ?n) ⊆ Keys (set (snd ?n))" .
qed
also have "dgrad_set_le d ... (pp_of_term ` Keys (set gs ∪ set fs))"
proof (simp only: image_Un Keys_Un dgrad_set_le_Un, rule)
show "dgrad_set_le d (pp_of_term ` Keys (set gs)) (pp_of_term ` Keys (set gs) ∪ pp_of_term ` Keys (set fs))"
by (rule dgrad_set_le_subset, simp)
next
have "dgrad_set_le d (pp_of_term ` Keys (set (snd ?n))) (pp_of_term ` (Keys (set fs) ∪ insert v (set (fst ?n))))"
by (rule dgrad_set_le_subset, auto simp only: Keys_snd_sym_preproc_addnew[symmetric])
also have "dgrad_set_le d ... (pp_of_term ` Keys (set fs) ∪ pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))"
proof (simp only: dgrad_set_le_Un image_Un, rule)
show "dgrad_set_le d (pp_of_term ` Keys (set fs))
(pp_of_term ` Keys (set fs) ∪ (pp_of_term ` Keys (set gs) ∪ pp_of_term ` insert v (set vs')))"
by (rule dgrad_set_le_subset, blast)
next
have "dgrad_set_le d (pp_of_term ` {v}) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))"
by (rule dgrad_set_le_subset, simp)
moreover from assms(1) have "dgrad_set_le d (pp_of_term ` set (fst ?n)) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))"
by (rule fst_sym_preproc_addnew_dgrad_set_le)
ultimately have "dgrad_set_le d (pp_of_term ` ({v} ∪ set (fst ?n))) (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))"
by (simp only: dgrad_set_le_Un image_Un)
also have "dgrad_set_le d (pp_of_term ` (Keys (set gs) ∪ insert v (set vs')))
(pp_of_term ` (Keys (set fs) ∪ (Keys (set gs) ∪ insert v (set vs'))))"
by (rule dgrad_set_le_subset, blast)
finally show "dgrad_set_le d (pp_of_term ` insert v (set (fst ?n)))
(pp_of_term ` Keys (set fs) ∪ (pp_of_term ` Keys (set gs) ∪ pp_of_term ` insert v (set vs')))"
by (simp add: image_Un)
qed
finally show "dgrad_set_le d (pp_of_term ` Keys (set (snd ?n))) (pp_of_term ` Keys (set gs) ∪ pp_of_term ` Keys (set fs))"
by (simp only: set_vs eq, metis eq image_Un)
qed
finally show ?case .
qed
lemma components_snd_sym_preproc_aux_subset:
assumes "set vs ⊆ Keys (set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list))"
shows "component_of_term ` Keys (set (snd (sym_preproc_aux gs ks (vs, fs)))) ⊆
component_of_term ` Keys (set gs ∪ set fs)"
using assms
proof (induct fs rule: sym_preproc_aux_induct)
case (base ks fs)
show ?case by (simp add: Keys_Un image_Un)
next
case (rec ks vs fs v vs')
let ?n = "sym_preproc_addnew gs vs' fs v"
from rec(1) have "v ∈ set vs" by (simp add: rec(2))
hence set_vs: "insert v (set vs') = set vs" by (auto simp add: rec(3))
from rec(5) have eq: "Keys (set fs) ∪ (Keys (set gs) ∪ set vs) = Keys (set gs) ∪ Keys (set fs)"
by blast
have "component_of_term ` Keys (set (snd (sym_preproc_aux gs (ks @ [v]) ?n))) ⊆
component_of_term ` Keys (set gs ∪ set (snd ?n))"
proof (rule rec(4))
have "set (fst ?n) ⊆ Keys (set (snd ?n)) ∪ insert v (set vs')"
by (simp only: Keys_snd_sym_preproc_addnew, blast)
also have "... = Keys (set (snd ?n)) ∪ (set vs)" by (simp only: set_vs)
also have "... ⊆ Keys (set (snd ?n))"
proof -
{
fix u
assume "u ∈ set vs"
with rec(5) have "u ∈ Keys (set fs)" ..
then obtain f where "f ∈ set fs" and "u ∈ keys f" by (rule in_KeysE)
from this(1) snd_sym_preproc_addnew_superset have "f ∈ set (snd ?n)" ..
with ‹u ∈ keys f› have "u ∈ Keys (set (snd ?n))" by (rule in_KeysI)
}
thus ?thesis by auto
qed
finally show "set (fst ?n) ⊆ Keys (set (snd ?n))" .
qed
also have "... ⊆ component_of_term ` Keys (set gs ∪ set fs)"
proof (simp only: image_Un Keys_Un Un_subset_iff, rule, fact Un_upper1)
have "component_of_term ` Keys (set (snd ?n)) ⊆ component_of_term ` (Keys (set fs) ∪ insert v (set (fst ?n)))"
by (auto simp only: Keys_snd_sym_preproc_addnew[symmetric])
also have "... ⊆ component_of_term ` Keys (set fs) ∪ component_of_term ` (Keys (set gs) ∪ insert v (set vs'))"
proof (simp only: Un_subset_iff image_Un, rule, fact Un_upper1)
have "component_of_term ` {v} ⊆ component_of_term ` (Keys (set gs) ∪ insert v (set vs'))"
by simp
moreover have "component_of_term ` set (fst ?n) ⊆ component_of_term ` (Keys (set gs) ∪ insert v (set vs'))"
by (rule components_fst_sym_preproc_addnew_subset)
ultimately have "component_of_term ` ({v} ∪ set (fst ?n)) ⊆ component_of_term ` (Keys (set gs) ∪ insert v (set vs'))"
by (simp only: Un_subset_iff image_Un)
also have "component_of_term ` (Keys (set gs) ∪ insert v (set vs')) ⊆
component_of_term ` (Keys (set fs) ∪ (Keys (set gs) ∪ insert v (set vs')))"
by blast
finally show "component_of_term ` insert v (set (fst ?n)) ⊆
component_of_term ` Keys (set fs) ∪
(component_of_term ` Keys (set gs) ∪ component_of_term ` insert v (set vs'))"
by (simp add: image_Un)
qed
finally show "component_of_term ` Keys (set (snd ?n)) ⊆
component_of_term ` Keys (set gs) ∪ component_of_term ` Keys (set fs)"
by (simp only: set_vs eq, metis eq image_Un)
qed
finally show ?case .
qed
lemma snd_sym_preproc_aux_complete:
assumes "⋀u' g'. u' ∈ Keys (set fs) ⟹ u' ∉ set vs ⟹ g' ∈ set gs ⟹ lt g' adds⇩t u' ⟹
monom_mult 1 (pp_of_term u' - lp g') g' ∈ set fs"
assumes "u ∈ Keys (set (snd (sym_preproc_aux gs ks (vs, fs))))" and "g ∈ set gs" and "lt g adds⇩t u"
shows "monom_mult (1::'b::semiring_1_no_zero_divisors) (pp_of_term u - lp g) g ∈
set (snd (sym_preproc_aux gs ks (vs, fs)))"
using assms
proof (induct fs rule: sym_preproc_aux_induct)
case (base ks fs)
from base(2) have "u ∈ Keys (set fs)" by simp
from this _ base(3, 4) have "monom_mult 1 (pp_of_term u - lp g) g ∈ set fs"
proof (rule base(1))
show "u ∉ set []" by simp
qed
thus ?case by simp
next
case (rec ks vs fs v vs')
from rec(1) have "v ∈ set vs" by (simp add: rec(2))
hence set_ts: "set vs = insert v (set vs')" by (auto simp add: rec(3))
let ?n = "sym_preproc_addnew gs vs' fs v"
from _ rec(6, 7, 8) show ?case
proof (rule rec(4))
fix v' g'
assume "v' ∈ Keys (set (snd ?n))" and "v' ∉ set (fst ?n)" and "g' ∈ set gs" and "lt g' adds⇩t v'"
from this(1) Keys_snd_sym_preproc_addnew have "v' ∈ Keys (set fs) ∪ insert v (set (fst ?n))"
by blast
with ‹v' ∉ set (fst ?n)› have disj: "v' ∈ Keys (set fs) ∨ v' = v" by blast
show "monom_mult 1 (pp_of_term v' - lp g') g' ∈ set (snd ?n)"
proof (cases "v' = v")
case True
from ‹g' ∈ set gs› ‹lt g' adds⇩t v'› show ?thesis
unfolding True by (rule sym_preproc_addnew_complete)
next
case False
with disj have "v' ∈ Keys (set fs)" by simp
moreover have "v' ∉ set vs"
proof
assume "v' ∈ set vs"
hence "v' ∈ set vs'" using False by (simp add: rec(3))
with fst_sym_preproc_addnew_superset have "v' ∈ set (fst ?n)" ..
with ‹v' ∉ set (fst ?n)› show False ..
qed
ultimately have "monom_mult 1 (pp_of_term v' - lp g') g' ∈ set fs"
using ‹g' ∈ set gs› ‹lt g' adds⇩t v'› by (rule rec(5))
with snd_sym_preproc_addnew_superset show ?thesis ..
qed
qed
qed
definition sym_preproc :: "('t ⇒⇩0 'b::semiring_1) list ⇒ ('t ⇒⇩0 'b) list ⇒ ('t list × ('t ⇒⇩0 'b) list)"
where "sym_preproc gs fs = sym_preproc_aux gs [] (Keys_to_list fs, fs)"
lemma sym_preproc_Nil [simp]: "sym_preproc gs [] = ([], [])"
by (simp add: sym_preproc_def)
lemma fst_sym_preproc:
"fst (sym_preproc gs fs) = Keys_to_list (snd (sym_preproc gs (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list)))"
proof -
let ?a = "fst (sym_preproc gs fs)"
let ?b = "Keys_to_list (snd (sym_preproc gs fs))"
have "antisymp (≻⇩t)" unfolding antisymp_def by fastforce
have "irreflp (≻⇩t)" by (simp add: irreflp_def)
moreover have "transp (≻⇩t)" unfolding transp_def by fastforce
moreover have s1: "sorted_wrt (≻⇩t) ?a" unfolding sym_preproc_def
by (rule fst_sym_preproc_aux_sorted_wrt, simp_all)
ultimately have d1: "distinct ?a" by (rule distinct_sorted_wrt_irrefl)
have s2: "sorted_wrt (≻⇩t) ?b" by (fact Keys_to_list_sorted_wrt)
with ‹irreflp (≻⇩t)› ‹transp (≻⇩t)› have d2: "distinct ?b" by (rule distinct_sorted_wrt_irrefl)
from ‹antisymp (≻⇩t)› s1 d1 s2 d2 show ?thesis
proof (rule sorted_wrt_distinct_set_unique)
show "set ?a = set ?b" unfolding set_Keys_to_list sym_preproc_def
by (rule fst_sym_preproc_aux_complete, simp add: set_Keys_to_list)
qed
qed
lemma snd_sym_preproc_superset: "set fs ⊆ set (snd (sym_preproc gs fs))"
by (simp only: sym_preproc_def snd_conv, fact snd_sym_preproc_aux_superset)
lemma in_snd_sym_preprocE:
assumes "p ∈ set (snd (sym_preproc gs fs))"
assumes 1: "p ∈ set fs ⟹ thesis"
assumes 2: "⋀g t. g ∈ set gs ⟹ p = monom_mult 1 t g ⟹ thesis"
shows thesis
using assms unfolding sym_preproc_def snd_conv by (rule in_snd_sym_preproc_auxE)
lemma snd_sym_preproc_pmdl: "pmdl (set gs ∪ set (snd (sym_preproc gs fs))) = pmdl (set gs ∪ set fs)"
unfolding sym_preproc_def snd_conv by (fact snd_sym_preproc_aux_pmdl)
lemma snd_sym_preproc_dgrad_set_le:
assumes "dickson_grading d"
shows "dgrad_set_le d (pp_of_term ` Keys (set (snd (sym_preproc gs fs))))
(pp_of_term ` Keys (set gs ∪ set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list)))"
unfolding sym_preproc_def snd_conv using assms
proof (rule snd_sym_preproc_aux_dgrad_set_le)
show "set (Keys_to_list fs) ⊆ Keys (set fs)" by (simp add: set_Keys_to_list)
qed
corollary snd_sym_preproc_dgrad_p_set_le:
assumes "dickson_grading d"
shows "dgrad_p_set_le d (set (snd (sym_preproc gs fs))) (set gs ∪ set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list))"
unfolding dgrad_p_set_le_def
proof -
from assms show "dgrad_set_le d (pp_of_term ` Keys (set (snd (sym_preproc gs fs)))) (pp_of_term ` Keys (set gs ∪ set fs))"
by (rule snd_sym_preproc_dgrad_set_le)
qed
lemma components_snd_sym_preproc_subset:
"component_of_term ` Keys (set (snd (sym_preproc gs fs))) ⊆
component_of_term ` Keys (set gs ∪ set (fs::('t ⇒⇩0 'b::semiring_1_no_zero_divisors) list))"
unfolding sym_preproc_def snd_conv
by (rule components_snd_sym_preproc_aux_subset, simp add: set_Keys_to_list)
lemma snd_sym_preproc_complete:
assumes "v ∈ Keys (set (snd (sym_preproc gs fs)))" and "g ∈ set gs" and "lt g adds⇩t v"
shows "monom_mult (1::'b::semiring_1_no_zero_divisors) (pp_of_term v - lp g) g ∈ set (snd (sym_preproc gs fs))"
using _ assms unfolding sym_preproc_def snd_conv
proof (rule snd_sym_preproc_aux_complete)
fix u' and g'::"'t ⇒⇩0 'b"
assume "u' ∈ Keys (set fs)" and "u' ∉ set (Keys_to_list fs)"
thus "monom_mult 1 (pp_of_term u' - lp g') g' ∈ set fs" by (simp add: set_Keys_to_list)
qed
end
subsection ‹‹lin_red››
context ordered_term
begin
definition lin_red :: "('t ⇒⇩0 'b::field) set ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b) ⇒ bool"
where "lin_red F p q ≡ (∃f∈F. red_single p q f 0)"
text ‹@{const lin_red} is a restriction of @{const red}, where the reductor (‹f›) may only be
multiplied by a constant factor, i.\,e. where the power-product is ‹0›.›
lemma lin_redI:
assumes "f ∈ F" and "red_single p q f 0"
shows "lin_red F p q"
unfolding lin_red_def using assms ..
lemma lin_redE:
assumes "lin_red F p q"
obtains f::"'t ⇒⇩0 'b::field" where "f ∈ F" and "red_single p q f 0"
proof -
from assms obtain f where "f ∈ F" and t: "red_single p q f 0" unfolding lin_red_def by blast
thus "?thesis" ..
qed
lemma lin_red_imp_red:
assumes "lin_red F p q"
shows "red F p q"
proof -
from assms obtain f where "f ∈ F" and "red_single p q f 0" by (rule lin_redE)
thus ?thesis by (rule red_setI)
qed
lemma lin_red_Un: "lin_red (F ∪ G) p q = (lin_red F p q ∨ lin_red G p q)"
proof
assume "lin_red (F ∪ G) p q"
then obtain f where "f ∈ F ∪ G" and r: "red_single p q f 0" by (rule lin_redE)
from this(1) show "lin_red F p q ∨ lin_red G p q"
proof
assume "f ∈ F"
from this r have "lin_red F p q" by (rule lin_redI)
thus ?thesis ..
next
assume "f ∈ G"
from this r have "lin_red G p q" by (rule lin_redI)
thus ?thesis ..
qed
next
assume "lin_red F p q ∨ lin_red G p q"
thus "lin_red (F ∪ G) p q"
proof
assume "lin_red F p q"
then obtain f where "f ∈ F" and r: "red_single p q f 0" by (rule lin_redE)
from this(1) have "f ∈ F ∪ G" by simp
from this r show ?thesis by (rule lin_redI)
next
assume "lin_red G p q"
then obtain g where "g ∈ G" and r: "red_single p q g 0" by (rule lin_redE)
from this(1) have "g ∈ F ∪ G" by simp
from this r show ?thesis by (rule lin_redI)
qed
qed
lemma lin_red_imp_red_rtrancl:
assumes "(lin_red F)⇧*⇧* p q"
shows "(red F)⇧*⇧* p q"
using assms
proof induct
case base
show ?case ..
next
case (step y z)
from step(2) have "red F y z" by (rule lin_red_imp_red)
with step(3) show ?case ..
qed
lemma phull_closed_lin_red:
assumes "phull B ⊆ phull A" and "p ∈ phull A" and "lin_red B p q"
shows "q ∈ phull A"
proof -
from assms(3) obtain f where "f ∈ B" and "red_single p q f 0" by (rule lin_redE)
hence q: "q = p - (lookup p (lt f) / lc f) ⋅ f"
by (simp add: red_single_def term_simps map_scale_eq_monom_mult)
have "q - p ∈ phull B"
by (simp add: q, rule phull.span_neg, rule phull.span_scale, rule phull.span_base, fact ‹f ∈ B›)
with assms(1) have "q - p ∈ phull A" ..
from this assms(2) have "(q - p) + p ∈ phull A" by (rule phull.span_add)
thus ?thesis by simp
qed
subsection ‹Reduction›
definition Macaulay_red :: "'t list ⇒ ('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::field) list"
where "Macaulay_red vs fs =
(let lts = map lt (filter (λp. p ≠ 0) fs) in
filter (λp. p ≠ 0 ∧ lt p ∉ set lts) (mat_to_polys vs (row_echelon (polys_to_mat vs fs)))
)"
text ‹‹Macaulay_red vs fs› auto-reduces (w.\,r.\,t. @{const lin_red}) the given list ‹fs› and returns
those non-zero polynomials whose leading terms are not in ‹lt_set (set fs)›.
Argument ‹vs› is expected to be ‹Keys_to_list fs›; this list is passed as an argument
to @{const Macaulay_red}, because it can be efficiently computed by symbolic preprocessing.›
lemma Macaulay_red_alt:
"Macaulay_red (Keys_to_list fs) fs = filter (λp. lt p ∉ lt_set (set fs)) (Macaulay_list fs)"
proof -
have "{x ∈ set fs. x ≠ 0} = set fs - {0}" by blast
thus ?thesis by (simp add: Macaulay_red_def Macaulay_list_def Macaulay_mat_def lt_set_def Let_def)
qed
lemma set_Macaulay_red:
"set (Macaulay_red (Keys_to_list fs) fs) = set (Macaulay_list fs) - {p. lt p ∈ lt_set (set fs)}"
by (auto simp add: Macaulay_red_alt)
lemma Keys_Macaulay_red: "Keys (set (Macaulay_red (Keys_to_list fs) fs)) ⊆ Keys (set fs)"
proof -
have "Keys (set (Macaulay_red (Keys_to_list fs) fs)) ⊆ Keys (set (Macaulay_list fs))"
unfolding set_Macaulay_red by (fact Keys_minus)
also have "... ⊆ Keys (set fs)" by (fact Keys_Macaulay_list)
finally show ?thesis .
qed
end
context gd_term
begin
lemma Macaulay_red_reducible:
assumes "f ∈ phull (set fs)" and "F ⊆ set fs" and "lt_set F = lt_set (set fs)"
shows "(lin_red (F ∪ set (Macaulay_red (Keys_to_list fs) fs)))⇧*⇧* f 0"
proof -
define A where "A = F ∪ set (Macaulay_red (Keys_to_list fs) fs)"
have phull_A: "phull A ⊆ phull (set fs)"
proof (rule phull.span_subset_spanI, simp add: A_def, rule)
have "F ⊆ phull F" by (rule phull.span_superset)
also from assms(2) have "... ⊆ phull (set fs)" by (rule phull.span_mono)
finally show "F ⊆ phull (set fs)" .
next
have "set (Macaulay_red (Keys_to_list fs) fs) ⊆ set (Macaulay_list fs)"
by (auto simp add: set_Macaulay_red)
also have "... ⊆ phull (set (Macaulay_list fs))" by (rule phull.span_superset)
also have "... = phull (set fs)" by (rule phull_Macaulay_list)
finally show "set (Macaulay_red (Keys_to_list fs) fs) ⊆ phull (set fs)" .
qed
have lt_A: "p ∈ phull (set fs) ⟹ p ≠ 0 ⟹ (⋀g. g ∈ A ⟹ g ≠ 0 ⟹ lt g = lt p ⟹ thesis) ⟹ thesis"
for p thesis
proof -
assume "p ∈ phull (set fs)" and "p ≠ 0"
then obtain g where g_in: "g ∈ set (Macaulay_list fs)" and "g ≠ 0" and "lt p = lt g"
by (rule Macaulay_list_lt)
assume *: "⋀g. g ∈ A ⟹ g ≠ 0 ⟹ lt g = lt p ⟹ thesis"
show ?thesis
proof (cases "g ∈ set (Macaulay_red (Keys_to_list fs) fs)")
case True
hence "g ∈ A" by (simp add: A_def)
from this ‹g ≠ 0› ‹lt p = lt g›[symmetric] show ?thesis by (rule *)
next
case False
with g_in have "lt g ∈ lt_set (set fs)" by (simp add: set_Macaulay_red)
also have "... = lt_set F" by (simp only: assms(3))
finally obtain g' where "g' ∈ F" and "g' ≠ 0" and "lt g' = lt g" by (rule lt_setE)
from this(1) have "g' ∈ A" by (simp add: A_def)
moreover note ‹g' ≠ 0›
moreover have "lt g' = lt p" by (simp only: ‹lt p = lt g› ‹lt g' = lt g›)
ultimately show ?thesis by (rule *)
qed
qed
from assms(2) finite_set have "finite F" by (rule finite_subset)
from this finite_set have fin_A: "finite A" unfolding A_def by (rule finite_UnI)
from ex_dgrad obtain d::"'a ⇒ nat" where dg: "dickson_grading d" ..
from fin_A have "finite (insert f A)" ..
then obtain m where "insert f A ⊆ dgrad_p_set d m" by (rule dgrad_p_set_exhaust)
hence A_sub: "A ⊆ dgrad_p_set d m" and "f ∈ dgrad_p_set d m" by simp_all
from dg have "wfP (dickson_less_p d m)" by (rule wf_dickson_less_p)
from this assms(1) ‹f ∈ dgrad_p_set d m› show "(lin_red A)⇧*⇧* f 0"
proof (induct f)
fix p
assume IH: "⋀q. dickson_less_p d m q p ⟹ q ∈ phull (set fs) ⟹ q ∈ dgrad_p_set d m ⟹
(lin_red A)⇧*⇧* q 0"
and "p ∈ phull (set fs)" and "p ∈ dgrad_p_set d m"
show "(lin_red A)⇧*⇧* p 0"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
with ‹p ∈ phull (set fs)› obtain g where "g ∈ A" and "g ≠ 0" and "lt g = lt p" by (rule lt_A)
define q where "q = p - monom_mult (lc p / lc g) 0 g"
from ‹g ∈ A› have lr: "lin_red A p q"
proof (rule lin_redI)
show "red_single p q g 0"
by (simp add: red_single_def ‹lt g = lt p› lc_def[symmetric] q_def ‹g ≠ 0› lc_not_0[OF False] term_simps)
qed
moreover have "(lin_red A)⇧*⇧* q 0"
proof -
from lr have red: "red A p q" by (rule lin_red_imp_red)
with dg A_sub ‹p ∈ dgrad_p_set d m› have "q ∈ dgrad_p_set d m" by (rule dgrad_p_set_closed_red)
moreover from red have "q ≺⇩p p" by (rule red_ord)
ultimately have "dickson_less_p d m q p" using ‹p ∈ dgrad_p_set d m›
by (simp add: dickson_less_p_def)
moreover from phull_A ‹p ∈ phull (set fs)› lr have "q ∈ phull (set fs)"
by (rule phull_closed_lin_red)
ultimately show ?thesis using ‹q ∈ dgrad_p_set d m› by (rule IH)
qed
ultimately show ?thesis by fastforce
qed
qed
qed
primrec pdata_pairs_to_list :: "('t, 'b::field, 'c) pdata_pair list ⇒ ('t ⇒⇩0 'b) list" where
"pdata_pairs_to_list [] = []"|
"pdata_pairs_to_list (p # ps) =
(let f = fst (fst p); g = fst (snd p); lf = lp f; lg = lp g; l = lcs lf lg in
(monom_mult (1 / lc f) (l - lf) f) # (monom_mult (1 / lc g) (l - lg) g) #
(pdata_pairs_to_list ps)
)"
lemma in_pdata_pairs_to_listI1:
assumes "(f, g) ∈ set ps"
shows "monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f)))
(fst f) ∈ set (pdata_pairs_to_list ps)" (is "?m ∈ _")
using assms
proof (induct ps)
case Nil
thus ?case by simp
next
case (Cons p ps)
from Cons(2) have "p = (f, g) ∨ (f, g) ∈ set ps" by auto
thus ?case
proof
assume "p = (f, g)"
show ?thesis by (simp add: ‹p = (f, g)› Let_def)
next
assume "(f, g) ∈ set ps"
hence "?m ∈ set (pdata_pairs_to_list ps)" by (rule Cons(1))
thus ?thesis by (simp add: Let_def)
qed
qed
lemma in_pdata_pairs_to_listI2:
assumes "(f, g) ∈ set ps"
shows "monom_mult (1 / lc (fst g)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst g)))
(fst g) ∈ set (pdata_pairs_to_list ps)" (is "?m ∈ _")
using assms
proof (induct ps)
case Nil
thus ?case by simp
next
case (Cons p ps)
from Cons(2) have "p = (f, g) ∨ (f, g) ∈ set ps" by auto
thus ?case
proof
assume "p = (f, g)"
show ?thesis by (simp add: ‹p = (f, g)› Let_def)
next
assume "(f, g) ∈ set ps"
hence "?m ∈ set (pdata_pairs_to_list ps)" by (rule Cons(1))
thus ?thesis by (simp add: Let_def)
qed
qed
lemma in_pdata_pairs_to_listE:
assumes "h ∈ set (pdata_pairs_to_list ps)"
obtains f g where "(f, g) ∈ set ps ∨ (g, f) ∈ set ps"
and "h = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)"
using assms
proof (induct ps arbitrary: thesis)
case Nil
from Nil(2) show ?case by simp
next
case (Cons p ps)
let ?f = "fst (fst p)"
let ?g = "fst (snd p)"
let ?lf = "lp ?f"
let ?lg = "lp ?g"
let ?l = "lcs ?lf ?lg"
from Cons(3) have "h = monom_mult (1 / lc ?f) (?l - ?lf) ?f ∨ h = monom_mult (1 / lc ?g) (?l - ?lg) ?g ∨
h ∈ set (pdata_pairs_to_list ps)"
by (simp add: Let_def)
thus ?case
proof (elim disjE)
assume h: "h = monom_mult (1 / lc ?f) (?l - ?lf) ?f"
have "(fst p, snd p) ∈ set (p # ps)" by simp
hence "(fst p, snd p) ∈ set (p # ps) ∨ (snd p, fst p) ∈ set (p # ps)" ..
from this h show ?thesis by (rule Cons(2))
next
assume h: "h = monom_mult (1 / lc ?g) (?l - ?lg) ?g"
have "(fst p, snd p) ∈ set (p # ps)" by simp
hence "(snd p, fst p) ∈ set (p # ps) ∨ (fst p, snd p) ∈ set (p # ps)" ..
moreover from h have "h = monom_mult (1 / lc ?g) ((lcs ?lg ?lf) - ?lg) ?g"
by (simp only: lcs_comm)
ultimately show ?thesis by (rule Cons(2))
next
assume h_in: "h ∈ set (pdata_pairs_to_list ps)"
obtain f g where "(f, g) ∈ set ps ∨ (g, f) ∈ set ps"
and h: "h = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)"
by (rule Cons(1), assumption, intro h_in)
from this(1) have "(f, g) ∈ set (p # ps) ∨ (g, f) ∈ set (p # ps)" by auto
from this h show ?thesis by (rule Cons(2))
qed
qed
definition f4_red_aux :: "('t, 'b::field, 'c) pdata list ⇒ ('t, 'b, 'c) pdata_pair list ⇒
('t ⇒⇩0 'b) list"
where "f4_red_aux bs ps =
(let aux = sym_preproc (map fst bs) (pdata_pairs_to_list ps) in Macaulay_red (fst aux) (snd aux))"
text ‹@{const f4_red_aux} only takes two arguments, since it does not distinguish between those
elements of the current basis that are known to be a Gr\"obner basis (called ‹gs› in
@{theory Groebner_Bases.Algorithm_Schema}) and the remaining ones.›
lemma f4_red_aux_not_zero: "0 ∉ set (f4_red_aux bs ps)"
by (simp add: f4_red_aux_def Let_def fst_sym_preproc set_Macaulay_red set_Macaulay_list)
lemma f4_red_aux_irredudible:
assumes "h ∈ set (f4_red_aux bs ps)" and "b ∈ set bs" and "fst b ≠ 0"
shows "¬ lt (fst b) adds⇩t lt h"
proof
from assms(1) f4_red_aux_not_zero have "h ≠ 0" by metis
hence "lt h ∈ keys h" by (rule lt_in_keys)
also from assms(1) have "... ⊆ Keys (set (f4_red_aux bs ps))" by (rule keys_subset_Keys)
also have "... ⊆ Keys (set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))"
(is "_ ⊆ Keys (set ?s)") by (simp only: f4_red_aux_def Let_def fst_sym_preproc Keys_Macaulay_red)
finally have "lt h ∈ Keys (set ?s)" .
moreover from assms(2) have "fst b ∈ set (map fst bs)" by auto
moreover assume a: "lt (fst b) adds⇩t lt h"
ultimately have "monom_mult 1 (lp h - lp (fst b)) (fst b) ∈ set ?s" (is "?m ∈ _")
by (rule snd_sym_preproc_complete)
from assms(3) have "?m ≠ 0" by (simp add: monom_mult_eq_zero_iff)
with ‹?m ∈ set ?s› have "lt ?m ∈ lt_set (set ?s)" by (rule lt_setI)
moreover from assms(3) a have "lt ?m = lt h"
by (simp add: lt_monom_mult, metis add_diff_cancel_right' adds_termE pp_of_term_splus)
ultimately have "lt h ∈ lt_set (set ?s)" by simp
moreover from assms(1) have "lt h ∉ lt_set (set ?s)"
by (simp add: f4_red_aux_def Let_def fst_sym_preproc set_Macaulay_red)
ultimately show False by simp
qed
lemma f4_red_aux_dgrad_p_set_le:
assumes "dickson_grading d"
shows "dgrad_p_set_le d (set (f4_red_aux bs ps)) (args_to_set ([], bs, ps))"
unfolding dgrad_p_set_le_def dgrad_set_le_def
proof
fix s
assume "s ∈ pp_of_term ` Keys (set (f4_red_aux bs ps))"
also have "... ⊆ pp_of_term ` Keys (set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))"
(is "_ ⊆ pp_of_term ` Keys (set ?s)")
by (rule image_mono, simp only: f4_red_aux_def Let_def fst_sym_preproc Keys_Macaulay_red)
finally have "s ∈ pp_of_term ` Keys (set ?s)" .
with snd_sym_preproc_dgrad_set_le[OF assms] obtain t
where "t ∈ pp_of_term ` Keys (set (map fst bs) ∪ set (pdata_pairs_to_list ps))" and "d s ≤ d t"
by (rule dgrad_set_leE)
from this(1) have "t ∈ pp_of_term ` Keys (fst ` set bs) ∨ t ∈ pp_of_term ` Keys (set (pdata_pairs_to_list ps))"
by (simp add: Keys_Un image_Un)
thus "∃t ∈ pp_of_term ` Keys (args_to_set ([], bs, ps)). d s ≤ d t"
proof
assume "t ∈ pp_of_term ` Keys (fst ` set bs)"
also have "... ⊆ pp_of_term ` Keys (args_to_set ([], bs, ps))"
by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_alt)
finally have "t ∈ pp_of_term ` Keys (args_to_set ([], bs, ps))" .
with ‹d s ≤ d t› show ?thesis ..
next
assume "t ∈ pp_of_term ` Keys (set (pdata_pairs_to_list ps))"
then obtain p where "p ∈ set (pdata_pairs_to_list ps)" and "t ∈ pp_of_term ` keys p"
by (auto elim: in_KeysE)
from this(1) obtain f g where disj: "(f, g) ∈ set ps ∨ (g, f) ∈ set ps"
and p: "p = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)"
by (rule in_pdata_pairs_to_listE)
from disj have "fst f ∈ args_to_set ([], bs, ps) ∧ fst g ∈ args_to_set ([], bs, ps)"
proof
assume "(f, g) ∈ set ps"
hence "f ∈ fst ` set ps" and "g ∈ snd ` set ps" by force+
hence "fst f ∈ fst ` fst ` set ps" and "fst g ∈ fst ` snd ` set ps" by simp_all
thus ?thesis by (simp add: args_to_set_def image_Un)
next
assume "(g, f) ∈ set ps"
hence "f ∈ snd ` set ps" and "g ∈ fst ` set ps" by force+
hence "fst f ∈ fst ` snd ` set ps" and "fst g ∈ fst ` fst ` set ps" by simp_all
thus ?thesis by (simp add: args_to_set_def image_Un)
qed
hence "fst f ∈ args_to_set ([], bs, ps)" and "fst g ∈ args_to_set ([], bs, ps)" by simp_all
hence keys_f: "keys (fst f) ⊆ Keys (args_to_set ([], bs, ps))"
and keys_g: "keys (fst g) ⊆ Keys (args_to_set ([], bs, ps))"
by (auto intro!: keys_subset_Keys)
let ?lf = "lp (fst f)"
let ?lg = "lp (fst g)"
define l where "l = lcs ?lf ?lg"
have "pp_of_term ` keys p ⊆ pp_of_term ` ((⊕) (lcs ?lf ?lg - ?lf) ` keys (fst f))" unfolding p
using keys_monom_mult_subset by (rule image_mono)
with ‹t ∈ pp_of_term ` keys p› have "t ∈ pp_of_term ` ((⊕) (l - ?lf) ` keys (fst f))" unfolding l_def ..
then obtain t' where "t' ∈ pp_of_term ` keys (fst f)" and t: "t = (l - ?lf) + t'"
using pp_of_term_splus by fastforce
from this(1) have "fst f ≠ 0" by auto
show ?thesis
proof (cases "fst g = 0")
case True
hence "?lg = 0" by (simp add: lt_def min_term_def term_simps)
hence "l = ?lf" by (simp add: l_def lcs_zero lcs_comm)
hence "t = t'" by (simp add: t)
with ‹d s ≤ d t› have "d s ≤ d t'" by simp
moreover from ‹t' ∈ pp_of_term ` keys (fst f)› keys_f have "t' ∈ pp_of_term ` Keys (args_to_set ([], bs, ps))"
by blast
ultimately show ?thesis ..
next
case False
have "d t = d (l - ?lf) ∨ d t = d t'"
by (auto simp add: t dickson_gradingD1[OF assms])
thus ?thesis
proof
assume "d t = d (l - ?lf)"
also from assms have "... ≤ ord_class.max (d ?lf) (d ?lg)"
unfolding l_def by (rule dickson_grading_lcs_minus)
finally have "d s ≤ d ?lf ∨ d s ≤ d ?lg" using ‹d s ≤ d t› by auto
thus ?thesis
proof
assume "d s ≤ d ?lf"
moreover have "lt (fst f) ∈ Keys (args_to_set ([], bs, ps))"
by (rule, rule lt_in_keys, fact+)
ultimately show ?thesis by blast
next
assume "d s ≤ d ?lg"
moreover have "lt (fst g) ∈ Keys (args_to_set ([], bs, ps))"
by (rule, rule lt_in_keys, fact+)
ultimately show ?thesis by blast
qed
next
assume "d t = d t'"
with ‹d s ≤ d t› have "d s ≤ d t'" by simp
moreover from ‹t' ∈ pp_of_term ` keys (fst f)› keys_f have "t' ∈ pp_of_term ` Keys (args_to_set ([], bs, ps))"
by blast
ultimately show ?thesis ..
qed
qed
qed
qed
lemma components_f4_red_aux_subset:
"component_of_term ` Keys (set (f4_red_aux bs ps)) ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))"
proof
fix k
assume "k ∈ component_of_term ` Keys (set (f4_red_aux bs ps))"
also have "... ⊆ component_of_term ` Keys (set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))"
by (rule image_mono, simp only: f4_red_aux_def Let_def fst_sym_preproc Keys_Macaulay_red)
also have "... ⊆ component_of_term ` Keys (set (map fst bs) ∪ set (pdata_pairs_to_list ps))"
by (fact components_snd_sym_preproc_subset)
finally have "k ∈ component_of_term ` Keys (fst ` set bs) ∪ component_of_term ` Keys (set (pdata_pairs_to_list ps))"
by (simp add: image_Un Keys_Un)
thus "k ∈ component_of_term ` Keys (args_to_set ([], bs, ps))"
proof
assume "k ∈ component_of_term ` Keys (fst ` set bs)"
also have "... ⊆ component_of_term ` Keys (args_to_set ([], bs, ps))"
by (rule image_mono, rule Keys_mono, auto simp add: args_to_set_alt)
finally show "k ∈ component_of_term ` Keys (args_to_set ([], bs, ps))" .
next
assume "k ∈ component_of_term ` Keys (set (pdata_pairs_to_list ps))"
then obtain p where "p ∈ set (pdata_pairs_to_list ps)" and "k ∈ component_of_term ` keys p"
by (auto elim: in_KeysE)
from this(1) obtain f g where disj: "(f, g) ∈ set ps ∨ (g, f) ∈ set ps"
and p: "p = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)"
by (rule in_pdata_pairs_to_listE)
from disj have "fst f ∈ args_to_set ([], bs, ps)"
by (simp add: args_to_set_alt, metis fst_conv image_eqI snd_conv)
hence "fst f ∈ args_to_set ([], bs, ps)" by simp
hence keys_f: "keys (fst f) ⊆ Keys (args_to_set ([], bs, ps))"
by (auto intro!: keys_subset_Keys)
let ?lf = "lp (fst f)"
let ?lg = "lp (fst g)"
define l where "l = lcs ?lf ?lg"
have "component_of_term ` keys p ⊆ component_of_term ` ((⊕) (lcs ?lf ?lg - ?lf) ` keys (fst f))"
unfolding p using keys_monom_mult_subset by (rule image_mono)
with ‹k ∈ component_of_term ` keys p› have "k ∈ component_of_term ` ((⊕) (l - ?lf) ` keys (fst f))"
unfolding l_def ..
hence "k ∈ component_of_term ` keys (fst f)" using component_of_term_splus by fastforce
with keys_f show "k ∈ component_of_term ` Keys (args_to_set ([], bs, ps))" by blast
qed
qed
lemma pmdl_f4_red_aux: "set (f4_red_aux bs ps) ⊆ pmdl (args_to_set ([], bs, ps))"
proof -
have "set (f4_red_aux bs ps) ⊆
set (Macaulay_list (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))"
by (auto simp add: f4_red_aux_def Let_def fst_sym_preproc set_Macaulay_red)
also have "... ⊆ pmdl (set (Macaulay_list (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps)))))"
by (fact pmdl.span_superset)
also have "... = pmdl (set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))"
by (fact pmdl_Macaulay_list)
also have "... ⊆ pmdl (set (map fst bs) ∪
set (snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))))"
by (rule pmdl.span_mono, blast)
also have "... = pmdl (set (map fst bs) ∪ set (pdata_pairs_to_list ps))"
by (fact snd_sym_preproc_pmdl)
also have "... ⊆ pmdl (args_to_set ([], bs, ps))"
proof (rule pmdl.span_subset_spanI, simp only: Un_subset_iff, rule conjI)
have "set (map fst bs) ⊆ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_def)
also have "... ⊆ pmdl (args_to_set ([], bs, ps))" by (rule pmdl.span_superset)
finally show "set (map fst bs) ⊆ pmdl (args_to_set ([], bs, ps))" .
next
show "set (pdata_pairs_to_list ps) ⊆ pmdl (args_to_set ([], bs, ps))"
proof
fix p
assume "p ∈ set (pdata_pairs_to_list ps)"
then obtain f g where "(f, g) ∈ set ps ∨ (g, f) ∈ set ps"
and p: "p = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)"
by (rule in_pdata_pairs_to_listE)
from this(1) have "f ∈ fst ` set ps ∪ snd ` set ps" by force
hence "fst f ∈ args_to_set ([], bs, ps)" by (auto simp add: args_to_set_alt)
hence "fst f ∈ pmdl (args_to_set ([], bs, ps))" by (rule pmdl.span_base)
thus "p ∈ pmdl (args_to_set ([], bs, ps))" unfolding p by (rule pmdl_closed_monom_mult)
qed
qed
finally show ?thesis .
qed
lemma f4_red_aux_phull_reducible:
assumes "set ps ⊆ set bs × set bs"
and "f ∈ phull (set (pdata_pairs_to_list ps))"
shows "(red (fst ` set bs ∪ set (f4_red_aux bs ps)))⇧*⇧* f 0"
proof -
define fs where "fs = snd (sym_preproc (map fst bs) (pdata_pairs_to_list ps))"
have "set (pdata_pairs_to_list ps) ⊆ set fs" unfolding fs_def by (fact snd_sym_preproc_superset)
hence "phull (set (pdata_pairs_to_list ps)) ⊆ phull (set fs)" by (rule phull.span_mono)
with assms(2) have f_in: "f ∈ phull (set fs)" ..
have eq: "(set fs) ∪ set (f4_red_aux bs ps) = (set fs) ∪ set (Macaulay_red (Keys_to_list fs) fs)"
by (simp add: f4_red_aux_def fs_def Let_def fst_sym_preproc)
have "(lin_red ((set fs) ∪ set (f4_red_aux bs ps)))⇧*⇧* f 0"
by (simp only: eq, rule Macaulay_red_reducible, fact f_in, fact subset_refl, fact refl)
thus ?thesis
proof induct
case base
show ?case ..
next
case (step y z)
from step(2) have "red (fst ` set bs ∪ set (f4_red_aux bs ps)) y z" unfolding lin_red_Un
proof
assume "lin_red (set fs) y z"
then obtain a where "a ∈ set fs" and r: "red_single y z a 0" by (rule lin_redE)
from this(1) obtain b c t where "b ∈ fst ` set bs" and a: "a = monom_mult c t b" unfolding fs_def
proof (rule in_snd_sym_preprocE)
assume *: "⋀b c t. b ∈ fst ` set bs ⟹ a = monom_mult c t b ⟹ thesis"
assume "a ∈ set (pdata_pairs_to_list ps)"
then obtain f g where "(f, g) ∈ set ps ∨ (g, f) ∈ set ps"
and a: "a = monom_mult (1 / lc (fst f)) ((lcs (lp (fst f)) (lp (fst g))) - (lp (fst f))) (fst f)"
by (rule in_pdata_pairs_to_listE)
from this(1) have "f ∈ fst ` set ps ∪ snd ` set ps" by force
with assms(1) have "f ∈ set bs" by fastforce
hence "fst f ∈ fst ` set bs" by simp
from this a show ?thesis by (rule *)
next
fix g s
assume *: "⋀b c t. b ∈ fst ` set bs ⟹ a = monom_mult c t b ⟹ thesis"
assume "g ∈ set (map fst bs)"
hence "g ∈ fst ` set bs" by simp
moreover assume "a = monom_mult 1 s g"
ultimately show ?thesis by (rule *)
qed
from r have "c ≠ 0" and "b ≠ 0" by (simp_all add: a red_single_def monom_mult_eq_zero_iff)
from r have "red_single y z b t"
by (simp add: a red_single_def monom_mult_eq_zero_iff lt_monom_mult[OF ‹c ≠ 0› ‹b ≠ 0›]
monom_mult_assoc term_simps)
with ‹b ∈ fst ` set bs› have "red (fst ` set bs) y z" by (rule red_setI)
thus ?thesis by (rule red_unionI1)
next
assume "lin_red (set (f4_red_aux bs ps)) y z"
hence "red (set (f4_red_aux bs ps)) y z" by (rule lin_red_imp_red)
thus ?thesis by (rule red_unionI2)
qed
with step(3) show ?case ..
qed
qed
corollary f4_red_aux_spoly_reducible:
assumes "set ps ⊆ set bs × set bs" and "(p, q) ∈ set ps"
shows "(red (fst ` set bs ∪ set (f4_red_aux bs ps)))⇧*⇧* (spoly (fst p) (fst q)) 0"
using assms(1)
proof (rule f4_red_aux_phull_reducible)
let ?lt = "lp (fst p)"
let ?lq = "lp (fst q)"
let ?l = "lcs ?lt ?lq"
let ?p = "monom_mult (1 / lc (fst p)) (?l - ?lt) (fst p)"
let ?q = "monom_mult (1 / lc (fst q)) (?l - ?lq) (fst q)"
from assms(2) have "?p ∈ set (pdata_pairs_to_list ps)" and "?q ∈ set (pdata_pairs_to_list ps)"
by (rule in_pdata_pairs_to_listI1, rule in_pdata_pairs_to_listI2)
hence "?p ∈ phull (set (pdata_pairs_to_list ps))" and "?q ∈ phull (set (pdata_pairs_to_list ps))"
by (auto intro: phull.span_base)
hence "?p - ?q ∈ phull (set (pdata_pairs_to_list ps))" by (rule phull.span_diff)
thus "spoly (fst p) (fst q) ∈ phull (set (pdata_pairs_to_list ps))"
by (simp add: spoly_def Let_def phull.span_zero lc_def split: if_split)
qed
definition f4_red :: "('t, 'b::field, 'c::default, 'd) complT"
where "f4_red gs bs ps sps data = (map (λh. (h, default)) (f4_red_aux (gs @ bs) sps), snd data)"
lemma fst_set_fst_f4_red: "fst ` set (fst (f4_red gs bs ps sps data)) = set (f4_red_aux (gs @ bs) sps)"
by (simp add: f4_red_def, force)
lemma rcp_spec_f4_red: "rcp_spec f4_red"
proof (rule rcp_specI)
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd"
show "0 ∉ fst ` set (fst (f4_red gs bs ps sps data))"
by (simp add: fst_set_fst_f4_red f4_red_aux_not_zero)
next
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps h b and data::"nat × 'd"
assume "h ∈ set (fst (f4_red gs bs ps sps data))" and "b ∈ set gs ∪ set bs"
from this(1) have "fst h ∈ fst ` set (fst (f4_red gs bs ps sps data))" by simp
hence "fst h ∈ set (f4_red_aux (gs @ bs) sps)" by (simp only: fst_set_fst_f4_red)
moreover from ‹b ∈ set gs ∪ set bs› have "b ∈ set (gs @ bs)" by simp
moreover assume "fst b ≠ 0"
ultimately show "¬ lt (fst b) adds⇩t lt (fst h)" by (rule f4_red_aux_irredudible)
next
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and d::"'a ⇒ nat" and data::"nat × 'd"
assume "dickson_grading d"
hence "dgrad_p_set_le d (set (f4_red_aux (gs @ bs) sps)) (args_to_set ([], gs @ bs, sps))"
by (fact f4_red_aux_dgrad_p_set_le)
also have "... = args_to_set (gs, bs, sps)" by (simp add: args_to_set_alt image_Un)
finally show "dgrad_p_set_le d (fst ` set (fst (f4_red gs bs ps sps data))) (args_to_set (gs, bs, sps))"
by (simp only: fst_set_fst_f4_red)
next
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd"
have "component_of_term ` Keys (set (f4_red_aux (gs @ bs) sps)) ⊆
component_of_term ` Keys (args_to_set ([], gs @ bs, sps))"
by (fact components_f4_red_aux_subset)
also have "... = component_of_term ` Keys (args_to_set (gs, bs, sps))"
by (simp add: args_to_set_alt image_Un)
finally show "component_of_term ` Keys (fst ` set (fst (f4_red gs bs ps sps data))) ⊆
component_of_term ` Keys (args_to_set (gs, bs, sps))"
by (simp only: fst_set_fst_f4_red)
next
fix gs bs::"('t, 'b, 'c) pdata list" and ps sps and data::"nat × 'd"
have "set (f4_red_aux (gs @ bs) sps) ⊆ pmdl (args_to_set ([], gs @ bs, sps))"
by (fact pmdl_f4_red_aux)
also have "... = pmdl (args_to_set (gs, bs, sps))" by (simp add: args_to_set_alt image_Un)
finally have "fst ` set (fst (f4_red gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps))"
by (simp only: fst_set_fst_f4_red)
moreover {
fix p q :: "('t, 'b, 'c) pdata"
assume "set sps ⊆ set bs × (set gs ∪ set bs)"
hence "set sps ⊆ set (gs @ bs) × set (gs @ bs)" by fastforce
moreover assume "(p, q) ∈ set sps"
ultimately have "(red (fst ` set (gs @ bs) ∪ set (f4_red_aux (gs @ bs) sps)))⇧*⇧* (spoly (fst p) (fst q)) 0"
by (rule f4_red_aux_spoly_reducible)
}
ultimately show
"fst ` set (fst (f4_red gs bs ps sps data)) ⊆ pmdl (args_to_set (gs, bs, sps)) ∧
(∀(p, q)∈set sps.
set sps ⊆ set bs × (set gs ∪ set bs) ⟶
(red (fst ` (set gs ∪ set bs) ∪ fst ` set (fst (f4_red gs bs ps sps data))))⇧*⇧* (spoly (fst p) (fst q)) 0)"
by (auto simp add: image_Un fst_set_fst_f4_red)
qed
lemmas compl_struct_f4_red = compl_struct_rcp[OF rcp_spec_f4_red]
lemmas compl_pmdl_f4_red = compl_pmdl_rcp[OF rcp_spec_f4_red]
lemmas compl_conn_f4_red = compl_conn_rcp[OF rcp_spec_f4_red]
subsection ‹Pair Selection›
primrec f4_sel_aux :: "'a ⇒ ('t, 'b::zero, 'c) pdata_pair list ⇒ ('t, 'b, 'c) pdata_pair list" where
"f4_sel_aux _ [] = []"|
"f4_sel_aux t (p # ps) =
(if (lcs (lp (fst (fst p))) (lp (fst (snd p)))) = t then
p # (f4_sel_aux t ps)
else
[]
)"
lemma f4_sel_aux_subset: "set (f4_sel_aux t ps) ⊆ set ps"
by (induct ps, auto)
primrec f4_sel :: "('t, 'b::zero, 'c, 'd) selT" where
"f4_sel gs bs [] data = []"|
"f4_sel gs bs (p # ps) data = p # (f4_sel_aux (lcs (lp (fst (fst p))) (lp (fst (snd p)))) ps)"
lemma sel_spec_f4_sel: "sel_spec f4_sel"
proof (rule sel_specI)
fix gs bs :: "('t, 'b, 'c) pdata list" and ps::"('t, 'b, 'c) pdata_pair list" and data::"nat × 'd"
assume "ps ≠ []"
then obtain p ps' where ps: "ps = p # ps'" by (meson list.exhaust)
show "f4_sel gs bs ps data ≠ [] ∧ set (f4_sel gs bs ps data) ⊆ set ps"
proof
show "f4_sel gs bs ps data ≠ []" by (simp add: ps)
next
from f4_sel_aux_subset show "set (f4_sel gs bs ps data) ⊆ set ps" by (auto simp add: ps)
qed
qed
subsection ‹The F4 Algorithm›
text ‹The F4 algorithm is just @{const gb_schema_direct} with parameters instantiated by suitable
functions.›
lemma struct_spec_f4: "struct_spec f4_sel add_pairs_canon add_basis_canon f4_red"
using sel_spec_f4_sel ap_spec_add_pairs_canon ab_spec_add_basis_sorted compl_struct_f4_red
by (rule struct_specI)
definition f4_aux :: "('t, 'b, 'c) pdata list ⇒ nat × nat × 'd ⇒ ('t, 'b, 'c) pdata list ⇒
('t, 'b, 'c) pdata_pair list ⇒ ('t, 'b::field, 'c::default) pdata list"
where "f4_aux = gb_schema_aux f4_sel add_pairs_canon add_basis_canon f4_red"
lemmas f4_aux_simps [code] = gb_schema_aux_simps[OF struct_spec_f4, folded f4_aux_def]
definition f4 :: "('t, 'b, 'c) pdata' list ⇒ 'd ⇒ ('t, 'b::field, 'c::default) pdata' list"
where "f4 = gb_schema_direct f4_sel add_pairs_canon add_basis_canon f4_red"
lemmas f4_simps [code] = gb_schema_direct_def[of f4_sel add_pairs_canon add_basis_canon f4_red, folded f4_def f4_aux_def]
lemmas f4_isGB = gb_schema_direct_isGB[OF struct_spec_f4 compl_conn_f4_red, folded f4_def]
lemmas f4_pmdl = gb_schema_direct_pmdl[OF struct_spec_f4 compl_pmdl_f4_red, folded f4_def]
subsubsection ‹Special Case: ‹punit››
lemma (in gd_term) struct_spec_f4_punit: "punit.struct_spec punit.f4_sel add_pairs_punit_canon punit.add_basis_canon punit.f4_red"
using punit.sel_spec_f4_sel ap_spec_add_pairs_punit_canon ab_spec_add_basis_sorted punit.compl_struct_f4_red
by (rule punit.struct_specI)
definition f4_aux_punit :: "('a, 'b, 'c) pdata list ⇒ nat × nat × 'd ⇒ ('a, 'b, 'c) pdata list ⇒
('a, 'b, 'c) pdata_pair list ⇒ ('a, 'b::field, 'c::default) pdata list"
where "f4_aux_punit = punit.gb_schema_aux punit.f4_sel add_pairs_punit_canon punit.add_basis_canon punit.f4_red"
lemmas f4_aux_punit_simps [code] = punit.gb_schema_aux_simps[OF struct_spec_f4_punit, folded f4_aux_punit_def]
definition f4_punit :: "('a, 'b, 'c) pdata' list ⇒ 'd ⇒ ('a, 'b::field, 'c::default) pdata' list"
where "f4_punit = punit.gb_schema_direct punit.f4_sel add_pairs_punit_canon punit.add_basis_canon punit.f4_red"
lemmas f4_punit_simps [code] = punit.gb_schema_direct_def[of "punit.f4_sel" add_pairs_punit_canon
"punit.add_basis_canon" "punit.f4_red", folded f4_punit_def f4_aux_punit_def]
lemmas f4_punit_isGB = punit.gb_schema_direct_isGB[OF struct_spec_f4_punit punit.compl_conn_f4_red, folded f4_punit_def]
lemmas f4_punit_pmdl = punit.gb_schema_direct_pmdl[OF struct_spec_f4_punit punit.compl_pmdl_f4_red, folded f4_punit_def]
end
end
Theory F4_Examples
section ‹Sample Computations with the F4 Algorithm›
theory F4_Examples
imports F4 Algorithm_Schema_Impl Jordan_Normal_Form.Gauss_Jordan_IArray_Impl Code_Target_Rat
begin
text ‹We only consider scalar polynomials here, but vector-polynomials could be handled, too.›
subsection ‹Preparations›
primrec remdups_wrt_rev :: "('a ⇒ 'b) ⇒ 'a list ⇒ 'b list ⇒ 'a list" where
"remdups_wrt_rev f [] vs = []" |
"remdups_wrt_rev f (x # xs) vs =
(let fx = f x in if List.member vs fx then remdups_wrt_rev f xs vs else x # (remdups_wrt_rev f xs (fx # vs)))"
lemma remdups_wrt_rev_notin: "v ∈ set vs ⟹ v ∉ f ` set (remdups_wrt_rev f xs vs)"
proof (induct xs arbitrary: vs)
case Nil
show ?case by simp
next
case (Cons x xs)
from Cons(2) have 1: "v ∉ f ` set (remdups_wrt_rev f xs vs)" by (rule Cons(1))
from Cons(2) have "v ∈ set (f x # vs)" by simp
hence 2: "v ∉ f ` set (remdups_wrt_rev f xs (f x # vs))" by (rule Cons(1))
from Cons(2) show ?case by (auto simp: Let_def 1 2 List.member_def)
qed
lemma distinct_remdups_wrt_rev: "distinct (map f (remdups_wrt_rev f xs vs))"
proof (induct xs arbitrary: vs)
case Nil
show ?case by simp
next
case (Cons x xs)
show ?case by (simp add: Let_def Cons(1) remdups_wrt_rev_notin)
qed
lemma map_of_remdups_wrt_rev':
"map_of (remdups_wrt_rev fst xs vs) k = map_of (filter (λx. fst x ∉ set vs) xs) k"
proof (induct xs arbitrary: vs)
case Nil
show ?case by simp
next
case (Cons x xs)
show ?case
proof (simp add: Let_def List.member_def Cons, intro impI)
assume "k ≠ fst x"
have "map_of (filter (λy. fst y ≠ fst x ∧ fst y ∉ set vs) xs) =
map_of (filter (λy. fst y ≠ fst x) (filter (λy. fst y ∉ set vs) xs))"
by (simp only: filter_filter conj_commute)
also have "... = map_of (filter (λy. fst y ∉ set vs) xs) |` {y. y ≠ fst x}" by (rule map_of_filter)
finally show "map_of (filter (λy. fst y ≠ fst x ∧ fst y ∉ set vs) xs) k =
map_of (filter (λy. fst y ∉ set vs) xs) k"
by (simp add: restrict_map_def ‹k ≠ fst x›)
qed
qed
corollary map_of_remdups_wrt_rev: "map_of (remdups_wrt_rev fst xs []) = map_of xs"
by (rule ext, simp add: map_of_remdups_wrt_rev')
lemma (in term_powerprod) compute_list_to_poly [code]:
"list_to_poly ts cs = distr⇩0 DRLEX (remdups_wrt_rev fst (zip ts cs) [])"
by (rule poly_mapping_eqI,
simp add: lookup_list_to_poly list_to_fun_def distr⇩0_def oalist_of_list_ntm_def
oa_ntm.lookup_oalist_of_list distinct_remdups_wrt_rev lookup_dflt_def map_of_remdups_wrt_rev)
lemma (in ordered_term) compute_Macaulay_list [code]:
"Macaulay_list ps =
(let ts = Keys_to_list ps in
filter (λp. p ≠ 0) (mat_to_polys ts (row_echelon (polys_to_mat ts ps)))
)"
by (simp add: Macaulay_list_def Macaulay_mat_def Let_def)
declare conversep_iff [code]
derive (eq) ceq poly_mapping
derive (no) ccompare poly_mapping
derive (dlist) set_impl poly_mapping
derive (no) cenum poly_mapping
derive (eq) ceq rat
derive (no) ccompare rat
derive (dlist) set_impl rat
derive (no) cenum rat
global_interpretation punit': gd_powerprod "ord_pp_punit cmp_term" "ord_pp_strict_punit cmp_term"
rewrites "punit.adds_term = (adds)"
and "punit.pp_of_term = (λx. x)"
and "punit.component_of_term = (λ_. ())"
and "punit.monom_mult = monom_mult_punit"
and "punit.mult_scalar = mult_scalar_punit"
and "punit'.punit.min_term = min_term_punit"
and "punit'.punit.lt = lt_punit cmp_term"
and "punit'.punit.lc = lc_punit cmp_term"
and "punit'.punit.tail = tail_punit cmp_term"
and "punit'.punit.ord_p = ord_p_punit cmp_term"
and "punit'.punit.ord_strict_p = ord_strict_p_punit cmp_term"
and "punit'.punit.keys_to_list = keys_to_list_punit cmp_term"
for cmp_term :: "('a::nat, 'b::{nat,add_wellorder}) pp nat_term_order"
defines max_punit = punit'.ordered_powerprod_lin.max
and max_list_punit = punit'.ordered_powerprod_lin.max_list
and find_adds_punit = punit'.punit.find_adds
and trd_aux_punit = punit'.punit.trd_aux
and trd_punit = punit'.punit.trd
and spoly_punit = punit'.punit.spoly
and count_const_lt_components_punit = punit'.punit.count_const_lt_components
and count_rem_components_punit = punit'.punit.count_rem_components
and const_lt_component_punit = punit'.punit.const_lt_component
and full_gb_punit = punit'.punit.full_gb
and add_pairs_single_sorted_punit = punit'.punit.add_pairs_single_sorted
and add_pairs_punit = punit'.punit.add_pairs
and canon_pair_order_aux_punit = punit'.punit.canon_pair_order_aux
and canon_basis_order_punit = punit'.punit.canon_basis_order
and new_pairs_sorted_punit = punit'.punit.new_pairs_sorted
and product_crit_punit = punit'.punit.product_crit
and chain_ncrit_punit = punit'.punit.chain_ncrit
and chain_ocrit_punit = punit'.punit.chain_ocrit
and apply_icrit_punit = punit'.punit.apply_icrit
and apply_ncrit_punit = punit'.punit.apply_ncrit
and apply_ocrit_punit = punit'.punit.apply_ocrit
and Keys_to_list_punit = punit'.punit.Keys_to_list
and sym_preproc_addnew_punit = punit'.punit.sym_preproc_addnew
and sym_preproc_aux_punit = punit'.punit.sym_preproc_aux
and sym_preproc_punit = punit'.punit.sym_preproc
and Macaulay_mat_punit = punit'.punit.Macaulay_mat
and Macaulay_list_punit = punit'.punit.Macaulay_list
and pdata_pairs_to_list_punit = punit'.punit.pdata_pairs_to_list
and Macaulay_red_punit = punit'.punit.Macaulay_red
and f4_sel_aux_punit = punit'.punit.f4_sel_aux
and f4_sel_punit = punit'.punit.f4_sel
and f4_red_aux_punit = punit'.punit.f4_red_aux
and f4_red_punit = punit'.punit.f4_red
and f4_aux_punit = punit'.punit.f4_aux_punit
and f4_punit = punit'.punit.f4_punit
subgoal by (fact gd_powerprod_ord_pp_punit)
subgoal by (fact punit_adds_term)
subgoal by (simp add: id_def)
subgoal by (fact punit_component_of_term)
subgoal by (simp only: monom_mult_punit_def)
subgoal by (simp only: mult_scalar_punit_def)
subgoal using min_term_punit_def by fastforce
subgoal by (simp only: lt_punit_def ord_pp_punit_alt)
subgoal by (simp only: lc_punit_def ord_pp_punit_alt)
subgoal by (simp only: tail_punit_def ord_pp_punit_alt)
subgoal by (simp only: ord_p_punit_def ord_pp_strict_punit_alt)
subgoal by (simp only: ord_strict_p_punit_def ord_pp_strict_punit_alt)
subgoal by (simp only: keys_to_list_punit_def ord_pp_punit_alt)
done
subsection ‹Computations›
experiment begin interpretation trivariate⇩0_rat .
lemma
"lt_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = sparse⇩0 [(0, 2), (2, 3)]"
by eval
lemma
"lc_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = 1"
by eval
lemma
"tail_punit DRLEX (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y) = 3 * X⇧2 * Y"
by eval
lemma
"ord_strict_p_punit DRLEX (X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2) (X⇧2 * Z ^ 7 + 2 * Y ^ 3 * Z⇧2)"
by eval
lemma
"f4_punit DRLEX
[
(X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2, ()),
(Y⇧2 * Z + 2 * Z ^ 3, ())
] () =
[
(X⇧2 * Y⇧2 * Z⇧2 + 4 * Y ^ 3 * Z⇧2, ()),
(X⇧2 * Z ^ 4 - 2 * Y ^ 3 * Z⇧2, ()),
(Y⇧2 * Z + 2 * Z ^ 3, ()),
(X⇧2 * Y ^ 4 * Z + 4 * Y ^ 5 * Z, ())
]"
by eval
lemma
"f4_punit DRLEX
[
(X⇧2 + Y⇧2 + Z⇧2 - 1, ()),
(X * Y - Z - 1, ()),
(Y⇧2 + X, ()),
(Z⇧2 + X, ())
] () =
[
(1, ())
]"
by eval
end
value [code] "length (f4_punit DRLEX (map (λp. (p, ())) ((cyclic DRLEX 4)::(_ ⇒⇩0 rat) list)) ())"
value [code] "length (f4_punit DRLEX (map (λp. (p, ())) ((katsura DRLEX 2)::(_ ⇒⇩0 rat) list)) ())"
end
Theory Syzygy
section ‹Syzygies of Multivariate Polynomials›
theory Syzygy
imports Groebner_Bases More_MPoly_Type_Class
begin
text ‹In this theory we first introduce the general concept of @{emph ‹syzygies›} in modules, and
then provide a method for computing Gr\"obner bases of syzygy modules of lists of multivariate
vector-polynomials. Since syzygies in this context are themselves represented by vector-polynomials,
this method can be applied repeatedly to compute bases of syzygy modules of syzygies, and so on.›
instance nat :: comm_powerprod ..
subsection ‹Syzygy Modules Generated by Sets›
context module
begin
definition rep :: "('b ⇒⇩0 'a) ⇒ 'b"
where "rep r = (∑v∈keys r. lookup r v *s v)"
definition represents :: "'b set ⇒ ('b ⇒⇩0 'a) ⇒ 'b ⇒ bool"
where "represents B r x ⟷ (keys r ⊆ B ∧ local.rep r = x)"
definition syzygy_module :: "'b set ⇒ ('b ⇒⇩0 'a) set"
where "syzygy_module B = {s. local.represents B s 0}"
end
hide_const (open) real_vector.rep real_vector.represents real_vector.syzygy_module
context module
begin
lemma rep_monomial [simp]: "rep (monomial c x) = c *s x"
proof -
have sub: "keys (monomial c x) ⊆ {x}" by simp
have "rep (monomial c x) = (∑v∈{x}. lookup (monomial c x) v *s v)" unfolding rep_def
by (rule sum.mono_neutral_left, simp, fact sub, simp)
also have "... = c *s x" by simp
finally show ?thesis .
qed
lemma rep_zero [simp]: "rep 0 = 0"
by (simp add: rep_def)
lemma rep_uminus [simp]: "rep (- r) = - rep r"
by (simp add: keys_uminus sum_negf rep_def)
lemma rep_plus: "rep (r + s) = rep r + rep s"
proof -
from finite_keys finite_keys have fin: "finite (keys r ∪ keys s)" by (rule finite_UnI)
from fin have eq1: "(∑v∈keys r ∪ keys s. lookup r v *s v) = (∑v∈keys r. lookup r v *s v)"
proof (rule sum.mono_neutral_right)
show "∀v∈keys r ∪ keys s - keys r. lookup r v *s v = 0" by (simp add: in_keys_iff)
qed simp
from fin have eq2: "(∑v∈keys r ∪ keys s. lookup s v *s v) = (∑v∈keys s. lookup s v *s v)"
proof (rule sum.mono_neutral_right)
show "∀v∈keys r ∪ keys s - keys s. lookup s v *s v = 0" by (simp add: in_keys_iff)
qed simp
have "rep (r + s) = (∑v∈keys (r + s). lookup (r + s) v *s v)" by (simp only: rep_def)
also have "... = (∑v∈keys r ∪ keys s. lookup (r + s) v *s v)"
proof (rule sum.mono_neutral_left)
show "∀i∈keys r ∪ keys s - keys (r + s). lookup (r + s) i *s i = 0" by (simp add: in_keys_iff)
qed (auto simp: Poly_Mapping.keys_add)
also have "... = (∑v∈keys r ∪ keys s. lookup r v *s v) + (∑v∈keys r ∪ keys s. lookup s v *s v)"
by (simp add: lookup_add scale_left_distrib sum.distrib)
also have "... = rep r + rep s" by (simp only: eq1 eq2 rep_def)
finally show ?thesis .
qed
lemma rep_minus: "rep (r - s) = rep r - rep s"
proof -
from finite_keys finite_keys have fin: "finite (keys r ∪ keys s)" by (rule finite_UnI)
from fin have eq1: "(∑v∈keys r ∪ keys s. lookup r v *s v) = (∑v∈keys r. lookup r v *s v)"
proof (rule sum.mono_neutral_right)
show "∀v∈keys r ∪ keys s - keys r. lookup r v *s v = 0" by (simp add: in_keys_iff)
qed simp
from fin have eq2: "(∑v∈keys r ∪ keys s. lookup s v *s v) = (∑v∈keys s. lookup s v *s v)"
proof (rule sum.mono_neutral_right)
show "∀v∈keys r ∪ keys s - keys s. lookup s v *s v = 0" by (simp add: in_keys_iff)
qed simp
have "rep (r - s) = (∑v∈keys (r - s). lookup (r - s) v *s v)" by (simp only: rep_def)
also from fin keys_minus have "... = (∑v∈keys r ∪ keys s. lookup (r - s) v *s v)"
proof (rule sum.mono_neutral_left)
show "∀i∈keys r ∪ keys s - keys (r - s). lookup (r - s) i *s i = 0" by (simp add: in_keys_iff)
qed
also have "... = (∑v∈keys r ∪ keys s. lookup r v *s v) - (∑v∈keys r ∪ keys s. lookup s v *s v)"
by (simp add: lookup_minus scale_left_diff_distrib sum_subtractf)
also have "... = rep r - rep s" by (simp only: eq1 eq2 rep_def)
finally show ?thesis .
qed
lemma rep_smult: "rep (monomial c 0 * r) = c *s rep r"
proof -
have l: "lookup (monomial c 0 * r) v = c * (lookup r v)" for v
unfolding mult_map_scale_conv_mult[symmetric] by (rule map_lookup, simp)
have sub: "keys (monomial c 0 * r) ⊆ keys r"
by (metis l lookup_not_eq_zero_eq_in_keys mult_zero_right subsetI)
have "rep (monomial c 0 * r) = (∑v∈keys (monomial c 0 * r). lookup (monomial c 0 * r) v *s v)"
by (simp only: rep_def)
also from finite_keys sub have "... = (∑v∈keys r. lookup (monomial c 0 * r) v *s v)"
proof (rule sum.mono_neutral_left)
show "∀v∈keys r - keys (monomial c 0 * r). lookup (monomial c 0 * r) v *s v = 0" by (simp add: in_keys_iff)
qed
also have "... = c *s (∑v∈keys r. lookup r v *s v)" by (simp add: l scale_sum_right)
also have "... = c *s rep r" by (simp add: rep_def)
finally show ?thesis .
qed
lemma rep_in_span: "rep r ∈ span (keys r)"
unfolding rep_def by (fact sum_in_spanI)
lemma spanE_rep:
assumes "x ∈ span B"
obtains r where "keys r ⊆ B" and "x = rep r"
proof -
from assms obtain A q where "finite A" and "A ⊆ B" and x: "x = (∑a∈A. q a *s a)" by (rule spanE)
define r where "r = Abs_poly_mapping (λk. q k when k ∈ A)"
have 1: "lookup r = (λk. q k when k ∈ A)" unfolding r_def
by (rule Abs_poly_mapping_inverse, simp add: ‹finite A›)
have 2: "keys r ⊆ A" by (auto simp: in_keys_iff 1)
show ?thesis
proof
have "x = (∑a∈A. lookup r a *s a)" unfolding x by (rule sum.cong, simp_all add: 1)
also from ‹finite A› 2 have "... = (∑a∈keys r. lookup r a *s a)"
proof (rule sum.mono_neutral_right)
show "∀a∈A - keys r. lookup r a *s a = 0" by (simp add: in_keys_iff)
qed
finally show "x = rep r" by (simp only: rep_def)
next
from 2 ‹A ⊆ B› show "keys r ⊆ B" by (rule subset_trans)
qed
qed
lemma representsI:
assumes "keys r ⊆ B" and "rep r = x"
shows "represents B r x"
unfolding represents_def using assms by blast
lemma representsD1:
assumes "represents B r x"
shows "keys r ⊆ B"
using assms unfolding represents_def by blast
lemma representsD2:
assumes "represents B r x"
shows "x = rep r"
using assms unfolding represents_def by blast
lemma represents_mono:
assumes "represents B r x" and "B ⊆ A"
shows "represents A r x"
proof (rule representsI)
from assms(1) have "keys r ⊆ B" by (rule representsD1)
thus "keys r ⊆ A" using assms(2) by (rule subset_trans)
next
from assms(1) have "x = rep r" by (rule representsD2)
thus "rep r = x" by (rule HOL.sym)
qed
lemma represents_self: "represents {x} (monomial 1 x) x"
proof -
have sub: "keys (monomial (1::'a) x) ⊆ {x}" by simp
moreover have "rep (monomial (1::'a) x) = x" by simp
ultimately show ?thesis by (rule representsI)
qed
lemma represents_zero: "represents B 0 0"
by (rule representsI, simp_all)
lemma represents_plus:
assumes "represents A r x" and "represents B s y"
shows "represents (A ∪ B) (r + s) (x + y)"
proof -
from assms(1) have r: "keys r ⊆ A" and x: "x = rep r" by (rule representsD1, rule representsD2)
from assms(2) have s: "keys s ⊆ B" and y: "y = rep s" by (rule representsD1, rule representsD2)
show ?thesis
proof (rule representsI)
from r s have "keys r ∪ keys s ⊆ A ∪ B" by blast
thus "keys (r + s) ⊆ A ∪ B"
by (meson Poly_Mapping.keys_add subset_trans)
qed (simp add: rep_plus x y)
qed
lemma represents_uminus:
assumes "represents B r x"
shows "represents B (- r) (- x)"
proof -
from assms have r: "keys r ⊆ B" and x: "x = rep r" by (rule representsD1, rule representsD2)
show ?thesis
proof (rule representsI)
from r show "keys (- r) ⊆ B" by (simp only: keys_uminus)
qed (simp add: x)
qed
lemma represents_minus:
assumes "represents A r x" and "represents B s y"
shows "represents (A ∪ B) (r - s) (x - y)"
proof -
from assms(1) have r: "keys r ⊆ A" and x: "x = rep r" by (rule representsD1, rule representsD2)
from assms(2) have s: "keys s ⊆ B" and y: "y = rep s" by (rule representsD1, rule representsD2)
show ?thesis
proof (rule representsI)
from r s have "keys r ∪ keys s ⊆ A ∪ B" by blast
with keys_minus show "keys (r - s) ⊆ A ∪ B" by (rule subset_trans)
qed (simp only: rep_minus x y)
qed
lemma represents_scale:
assumes "represents B r x"
shows "represents B (monomial c 0 * r) (c *s x)"
proof -
from assms have r: "keys r ⊆ B" and x: "x = rep r" by (rule representsD1, rule representsD2)
show ?thesis
proof (rule representsI)
have l: "lookup (monomial c 0 * r) v = c * (lookup r v)" for v
unfolding mult_map_scale_conv_mult[symmetric] by (rule map_lookup, simp)
have sub: "keys (monomial c 0 * r) ⊆ keys r"
by (metis l lookup_not_eq_zero_eq_in_keys mult_zero_right subsetI)
thus "keys (monomial c 0 * r) ⊆ B" using r by (rule subset_trans)
qed (simp only: rep_smult x)
qed
lemma represents_in_span:
assumes "represents B r x"
shows "x ∈ span B"
proof -
from assms have r: "keys r ⊆ B" and x: "x = rep r" by (rule representsD1, rule representsD2)
have "x ∈ span (keys r)" unfolding x by (fact rep_in_span)
also from r have "... ⊆ span B" by (rule span_mono)
finally show ?thesis .
qed
lemma syzygy_module_iff: "s ∈ syzygy_module B ⟷ represents B s 0"
by (simp add: syzygy_module_def)
lemma syzygy_moduleI:
assumes "represents B s 0"
shows "s ∈ syzygy_module B"
unfolding syzygy_module_iff using assms .
lemma syzygy_moduleD:
assumes "s ∈ syzygy_module B"
shows "represents B s 0"
using assms unfolding syzygy_module_iff .
lemma zero_in_syzygy_module: "0 ∈ syzygy_module B"
using represents_zero by (rule syzygy_moduleI)
lemma syzygy_module_closed_plus:
assumes "s1 ∈ syzygy_module B" and "s2 ∈ syzygy_module B"
shows "s1 + s2 ∈ syzygy_module B"
proof -
from assms(1) have "represents B s1 0" by (rule syzygy_moduleD)
moreover from assms(2) have "represents B s2 0" by (rule syzygy_moduleD)
ultimately have "represents (B ∪ B) (s1 + s2) (0 + 0)" by (rule represents_plus)
hence "represents B (s1 + s2) 0" by simp
thus ?thesis by (rule syzygy_moduleI)
qed
lemma syzygy_module_closed_minus:
assumes "s1 ∈ syzygy_module B" and "s2 ∈ syzygy_module B"
shows "s1 - s2 ∈ syzygy_module B"
proof -
from assms(1) have "represents B s1 0" by (rule syzygy_moduleD)
moreover from assms(2) have "represents B s2 0" by (rule syzygy_moduleD)
ultimately have "represents (B ∪ B) (s1 - s2) (0 - 0)" by (rule represents_minus)
hence "represents B (s1 - s2) 0" by simp
thus ?thesis by (rule syzygy_moduleI)
qed
lemma syzygy_module_closed_times_monomial:
assumes "s ∈ syzygy_module B"
shows "monomial c 0 * s ∈ syzygy_module B"
proof -
from assms(1) have "represents B s 0" by (rule syzygy_moduleD)
hence "represents B (monomial c 0 * s) (c *s 0)" by (rule represents_scale)
hence "represents B (monomial c 0 * s) 0" by simp
thus ?thesis by (rule syzygy_moduleI)
qed
end
context term_powerprod
begin
lemma keys_rep_subset:
assumes "u ∈ keys (pmdl.rep r)"
obtains t v where "t ∈ Keys (Poly_Mapping.range r)" and "v ∈ Keys (keys r)" and "u = t ⊕ v"
proof -
note assms
also have "keys (pmdl.rep r) ⊆ (⋃v∈keys r. keys (lookup r v ⊙ v))"
by (simp add: pmdl.rep_def keys_sum_subset)
finally obtain v0 where "v0 ∈ keys r" and "u ∈ keys (lookup r v0 ⊙ v0)" ..
from this(2) obtain t v where "t ∈ keys (lookup r v0)" and "v ∈ keys v0" and "u = t ⊕ v"
by (rule in_keys_mult_scalarE)
show ?thesis
proof
from ‹v0 ∈ keys r› have "lookup r v0 ∈ Poly_Mapping.range r" by (rule in_keys_lookup_in_range)
with ‹t ∈ keys (lookup r v0)› show "t ∈ Keys (Poly_Mapping.range r)" by (rule in_KeysI)
next
from ‹v ∈ keys v0› ‹v0 ∈ keys r› show "v ∈ Keys (keys r)" by (rule in_KeysI)
qed fact
qed
lemma rep_mult_scalar: "pmdl.rep (punit.monom_mult c 0 r) = c ⊙ pmdl.rep r"
unfolding punit.mult_scalar_monomial[symmetric] punit_mult_scalar by (fact pmdl.rep_smult)
lemma represents_mult_scalar:
assumes "pmdl.represents B r x"
shows "pmdl.represents B (punit.monom_mult c 0 r) (c ⊙ x)"
unfolding punit.mult_scalar_monomial[symmetric] punit_mult_scalar using assms
by (rule pmdl.represents_scale)
lemma syzygy_module_closed_map_scale: "s ∈ pmdl.syzygy_module B ⟹ c ⋅ s ∈ pmdl.syzygy_module B"
unfolding map_scale_eq_times by (rule pmdl.syzygy_module_closed_times_monomial)
lemma phull_syzygy_module: "phull (pmdl.syzygy_module B) = pmdl.syzygy_module B"
unfolding phull.span_eq_iff
apply (rule phull.subspaceI)
subgoal by (fact pmdl.zero_in_syzygy_module)
subgoal by (fact pmdl.syzygy_module_closed_plus)
subgoal by (fact syzygy_module_closed_map_scale)
done
end
subsection ‹Polynomial Mappings on List-Indices›
definition pm_of_idx_pm :: "('a list) ⇒ (nat ⇒⇩0 'b) ⇒ 'a ⇒⇩0 'b::zero"
where "pm_of_idx_pm xs f = Abs_poly_mapping (λx. lookup f (Min {i. i < length xs ∧ xs ! i = x}) when x ∈ set xs)"
definition idx_pm_of_pm :: "('a list) ⇒ ('a ⇒⇩0 'b) ⇒ nat ⇒⇩0 'b::zero"
where "idx_pm_of_pm xs f = Abs_poly_mapping (λi. lookup f (xs ! i) when i < length xs)"
lemma lookup_pm_of_idx_pm:
"lookup (pm_of_idx_pm xs f) = (λx. lookup f (Min {i. i < length xs ∧ xs ! i = x}) when x ∈ set xs)"
unfolding pm_of_idx_pm_def by (rule Abs_poly_mapping_inverse, simp)
lemma lookup_pm_of_idx_pm_distinct:
assumes "distinct xs" and "i < length xs"
shows "lookup (pm_of_idx_pm xs f) (xs ! i) = lookup f i"
proof -
from assms have "{j. j < length xs ∧ xs ! j = xs ! i} = {i}"
using distinct_Ex1 nth_mem by fastforce
moreover from assms(2) have "xs ! i ∈ set xs" by (rule nth_mem)
ultimately show ?thesis by (simp add: lookup_pm_of_idx_pm)
qed
lemma keys_pm_of_idx_pm_subset: "keys (pm_of_idx_pm xs f) ⊆ set xs"
proof
fix t
assume "t ∈ keys (pm_of_idx_pm xs f)"
hence "lookup (pm_of_idx_pm xs f) t ≠ 0" by (simp add: in_keys_iff)
thus "t ∈ set xs" by (simp add: lookup_pm_of_idx_pm)
qed
lemma range_pm_of_idx_pm_subset: "Poly_Mapping.range (pm_of_idx_pm xs f) ⊆ lookup f ` {0..<length xs} - {0}"
proof
fix c
assume "c ∈ Poly_Mapping.range (pm_of_idx_pm xs f)"
then obtain t where t: "t ∈ keys (pm_of_idx_pm xs f)" and c: "c = lookup (pm_of_idx_pm xs f) t"
by (metis DiffE imageE insertCI not_in_keys_iff_lookup_eq_zero range.rep_eq)
from t keys_pm_of_idx_pm_subset have "t ∈ set xs" ..
hence c1: "c = lookup f (Min {i. i < length xs ∧ xs ! i = t})" by (simp add: lookup_pm_of_idx_pm c)
show "c ∈ lookup f ` {0..<length xs} - {0}"
proof (intro DiffI image_eqI)
from ‹t ∈ set xs› obtain i where "i < length xs" and "t = xs ! i" by (metis in_set_conv_nth)
have "finite {i. i < length xs ∧ xs ! i = t}" by simp
moreover from ‹i < length xs› ‹t = xs ! i› have "{i. i < length xs ∧ xs ! i = t} ≠ {}" by auto
ultimately have "Min {i. i < length xs ∧ xs ! i = t} ∈ {i. i < length xs ∧ xs ! i = t}"
by (rule Min_in)
thus "Min {i. i < length xs ∧ xs ! i = t} ∈ {0..<length xs}" by simp
next
from t show "c ∉ {0}" by (simp add: c in_keys_iff)
qed (fact c1)
qed
corollary range_pm_of_idx_pm_subset': "Poly_Mapping.range (pm_of_idx_pm xs f) ⊆ Poly_Mapping.range f"
using range_pm_of_idx_pm_subset
proof (rule subset_trans)
show "lookup f ` {0..<length xs} - {0} ⊆ Poly_Mapping.range f" by (transfer, auto)
qed
lemma pm_of_idx_pm_zero [simp]: "pm_of_idx_pm xs 0 = 0"
by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm)
lemma pm_of_idx_pm_plus: "pm_of_idx_pm xs (f + g) = pm_of_idx_pm xs f + pm_of_idx_pm xs g"
by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm lookup_add when_def)
lemma pm_of_idx_pm_uminus: "pm_of_idx_pm xs (- f) = - pm_of_idx_pm xs f"
by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm when_def)
lemma pm_of_idx_pm_minus: "pm_of_idx_pm xs (f - g) = pm_of_idx_pm xs f - pm_of_idx_pm xs g"
by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm lookup_minus when_def)
lemma pm_of_idx_pm_monom_mult: "pm_of_idx_pm xs (punit.monom_mult c 0 f) = punit.monom_mult c 0 (pm_of_idx_pm xs f)"
by (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm punit.lookup_monom_mult_zero when_def)
lemma pm_of_idx_pm_monomial:
assumes "distinct xs"
shows "pm_of_idx_pm xs (monomial c i) = (monomial c (xs ! i) when i < length xs)"
proof -
from assms have *: "{i. i < length xs ∧ xs ! i = xs ! j} = {j}" if "j < length xs" for j
using distinct_Ex1 nth_mem that by fastforce
show ?thesis
proof (cases "i < length xs")
case True
have "pm_of_idx_pm xs (monomial c i) = monomial c (xs ! i)"
proof (rule poly_mapping_eqI)
fix k
show "lookup (pm_of_idx_pm xs (monomial c i)) k = lookup (monomial c (xs ! i)) k"
proof (cases "xs ! i = k")
case True
with ‹i < length xs› have "k ∈ set xs" by auto
thus ?thesis by (simp add: lookup_pm_of_idx_pm lookup_single *[OF ‹i < length xs›] True[symmetric])
next
case False
have "lookup (pm_of_idx_pm xs (monomial c i)) k = 0"
proof (cases "k ∈ set xs")
case True
then obtain j where "j < length xs" and "k = xs ! j" by (metis in_set_conv_nth)
with False have "i ≠ Min {i. i < length xs ∧ xs ! i = k}"
by (auto simp: ‹k = xs ! j› *[OF ‹j < length xs›])
thus ?thesis by (simp add: lookup_pm_of_idx_pm True lookup_single)
next
case False
thus ?thesis by (simp add: lookup_pm_of_idx_pm)
qed
with False show ?thesis by (simp add: lookup_single)
qed
qed
with True show ?thesis by simp
next
case False
have "pm_of_idx_pm xs (monomial c i) = 0"
proof (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm when_def, rule)
fix k
assume "k ∈ set xs"
then obtain j where "j < length xs" and "k = xs ! j" by (metis in_set_conv_nth)
with False have "i ≠ Min {i. i < length xs ∧ xs ! i = k}"
by (auto simp: ‹k = xs ! j› *[OF ‹j < length xs›])
thus "lookup (monomial c i) (Min {i. i < length xs ∧ xs ! i = k}) = 0"
by (simp add: lookup_single)
qed
with False show ?thesis by simp
qed
qed
lemma pm_of_idx_pm_take:
assumes "keys f ⊆ {0..<j}"
shows "pm_of_idx_pm (take j xs) f = pm_of_idx_pm xs f"
proof (rule poly_mapping_eqI)
fix i
let ?xs = "take j xs"
let ?A = "{k. k < length xs ∧ xs ! k = i}"
let ?B = "{k. k < length xs ∧ k < j ∧ xs ! k = i}"
have A_fin: "finite ?A" and B_fin: "finite ?B" by fastforce+
have A_ne: "i ∈ set xs ⟹ ?A ≠ {}" by (simp add: in_set_conv_nth)
have B_ne: "i ∈ set ?xs ⟹ ?B ≠ {}" by (auto simp add: in_set_conv_nth)
define m1 where "m1 = Min ?A"
define m2 where "m2 = Min ?B"
have m1: "m1 ∈ ?A" if "i ∈ set xs"
unfolding m1_def by (rule Min_in, fact A_fin, rule A_ne, fact that)
have m2: "m2 ∈ ?B" if "i ∈ set ?xs"
unfolding m2_def by (rule Min_in, fact B_fin, rule B_ne, fact that)
show "lookup (pm_of_idx_pm (take j xs) f) i = lookup (pm_of_idx_pm xs f) i"
proof (cases "i ∈ set ?xs")
case True
hence "i ∈ set xs" using set_take_subset ..
hence "m1 ∈ ?A" by (rule m1)
hence "m1 < length xs" and "xs ! m1 = i" by simp_all
from True have "m2 ∈ ?B" by (rule m2)
hence "m2 < length xs" and "m2 < j" and "xs ! m2 = i" by simp_all
hence "m2 ∈ ?A" by simp
with A_fin have "m1 ≤ m2" unfolding m1_def by (rule Min_le)
with ‹m2 < j› have "m1 < j" by simp
with ‹m1 < length xs› ‹xs ! m1 = i› have "m1 ∈ ?B" by simp
with B_fin have "m2 ≤ m1" unfolding m2_def by (rule Min_le)
with ‹m1 ≤ m2› have "m1 = m2" by (rule le_antisym)
with True ‹i ∈ set xs› show ?thesis by (simp add: lookup_pm_of_idx_pm m1_def m2_def cong: conj_cong)
next
case False
thus ?thesis
proof (simp add: lookup_pm_of_idx_pm when_def m1_def[symmetric], intro impI)
assume "i ∈ set xs"
hence "m1 ∈ ?A" by (rule m1)
hence "m1 < length xs" and "xs ! m1 = i" by simp_all
have "m1 ∉ keys f"
proof
assume "m1 ∈ keys f"
hence "m1 ∈ {0..<j}" using assms ..
hence "m1 < j" by simp
with ‹m1 < length xs› have "m1 < length ?xs" by simp
hence "?xs ! m1 ∈ set ?xs" by (rule nth_mem)
with ‹m1 < j› have "i ∈ set ?xs" by (simp add: ‹xs ! m1 = i›)
with False show False ..
qed
thus "lookup f m1 = 0" by (simp add: in_keys_iff)
qed
qed
qed
lemma lookup_idx_pm_of_pm: "lookup (idx_pm_of_pm xs f) = (λi. lookup f (xs ! i) when i < length xs)"
unfolding idx_pm_of_pm_def by (rule Abs_poly_mapping_inverse, simp)
lemma keys_idx_pm_of_pm_subset: "keys (idx_pm_of_pm xs f) ⊆ {0..<length xs}"
proof
fix i
assume "i ∈ keys (idx_pm_of_pm xs f)"
hence "lookup (idx_pm_of_pm xs f) i ≠ 0" by (simp add: in_keys_iff)
thus "i ∈ {0..<length xs}" by (simp add: lookup_idx_pm_of_pm)
qed
lemma idx_pm_of_pm_zero [simp]: "idx_pm_of_pm xs 0 = 0"
by (rule poly_mapping_eqI, simp add: lookup_idx_pm_of_pm)
lemma idx_pm_of_pm_plus: "idx_pm_of_pm xs (f + g) = idx_pm_of_pm xs f + idx_pm_of_pm xs g"
by (rule poly_mapping_eqI, simp add: lookup_idx_pm_of_pm lookup_add when_def)
lemma idx_pm_of_pm_minus: "idx_pm_of_pm xs (f - g) = idx_pm_of_pm xs f - idx_pm_of_pm xs g"
by (rule poly_mapping_eqI, simp add: lookup_idx_pm_of_pm lookup_minus when_def)
lemma pm_of_idx_pm_of_pm:
assumes "keys f ⊆ set xs"
shows "pm_of_idx_pm xs (idx_pm_of_pm xs f) = f"
proof (rule poly_mapping_eqI, simp add: lookup_pm_of_idx_pm when_def, intro conjI impI)
fix k
assume "k ∈ set xs"
define i where "i = Min {i. i < length xs ∧ xs ! i = k}"
have "finite {i. i < length xs ∧ xs ! i = k}" by simp
moreover from ‹k ∈ set xs› have "{i. i < length xs ∧ xs ! i = k} ≠ {}"
by (simp add: in_set_conv_nth)
ultimately have "i ∈ {i. i < length xs ∧ xs ! i = k}" unfolding i_def by (rule Min_in)
hence "i < length xs" and "xs ! i = k" by simp_all
thus "lookup (idx_pm_of_pm xs f) i = lookup f k" by (simp add: lookup_idx_pm_of_pm)
next
fix k
assume "k ∉ set xs"
with assms show "lookup f k = 0" by (auto simp: in_keys_iff)
qed
lemma idx_pm_of_pm_of_idx_pm:
assumes "distinct xs" and "keys f ⊆ {0..<length xs}"
shows "idx_pm_of_pm xs (pm_of_idx_pm xs f) = f"
proof (rule poly_mapping_eqI)
fix i
show "lookup (idx_pm_of_pm xs (pm_of_idx_pm xs f)) i = lookup f i"
proof (cases "i < length xs")
case True
with assms(1) show ?thesis by (simp add: lookup_idx_pm_of_pm lookup_pm_of_idx_pm_distinct)
next
case False
hence "i ∉ {0..<length xs}" by simp
with assms(2) have "i ∉ keys f" by blast
with False show ?thesis by (simp add: in_keys_iff lookup_idx_pm_of_pm)
qed
qed
subsection ‹POT Orders›
context ordered_term
begin
definition is_pot_ord :: bool
where "is_pot_ord ⟷ (∀u v. component_of_term u < component_of_term v ⟶ u ≺⇩t v)"
lemma is_pot_ordI:
assumes "⋀u v. component_of_term u < component_of_term v ⟹ u ≺⇩t v"
shows "is_pot_ord"
unfolding is_pot_ord_def using assms by blast
lemma is_pot_ordD:
assumes "is_pot_ord" and "component_of_term u < component_of_term v"
shows "u ≺⇩t v"
using assms unfolding is_pot_ord_def by blast
lemma is_pot_ordD2:
assumes "is_pot_ord" and "u ≼⇩t v"
shows "component_of_term u ≤ component_of_term v"
proof (rule ccontr)
assume "¬ component_of_term u ≤ component_of_term v"
hence "component_of_term v < component_of_term u" by simp
with assms(1) have "v ≺⇩t u" by (rule is_pot_ordD)
with assms(2) show False by simp
qed
lemma is_pot_ord:
assumes "is_pot_ord"
shows "u ≼⇩t v ⟷ (component_of_term u < component_of_term v ∨
(component_of_term u = component_of_term v ∧ pp_of_term u ≼ pp_of_term v))" (is "?l ⟷ ?r")
proof
assume ?l
with assms have "component_of_term u ≤ component_of_term v" by (rule is_pot_ordD2)
hence "component_of_term u < component_of_term v ∨ component_of_term u = component_of_term v"
by (simp add: order_class.le_less)
thus ?r
proof
assume "component_of_term u < component_of_term v"
thus ?r ..
next
assume 1: "component_of_term u = component_of_term v"
moreover have "pp_of_term u ≼ pp_of_term v"
proof (rule ccontr)
assume "¬ pp_of_term u ≼ pp_of_term v"
hence 2: "pp_of_term v ≼ pp_of_term u" and 3: "pp_of_term u ≠ pp_of_term v" by simp_all
from 1 have "component_of_term v ≤ component_of_term u" by simp
with 2 have "v ≼⇩t u" by (rule ord_termI)
with ‹?l› have "u = v" by simp
with 3 show False by simp
qed
ultimately show ?r by simp
qed
next
assume ?r
thus ?l
proof
assume "component_of_term u < component_of_term v"
with assms have "u ≺⇩t v" by (rule is_pot_ordD)
thus ?l by simp
next
assume "component_of_term u = component_of_term v ∧ pp_of_term u ≼ pp_of_term v"
hence "pp_of_term u ≼ pp_of_term v" and "component_of_term u ≤ component_of_term v" by simp_all
thus ?l by (rule ord_termI)
qed
qed
definition map_component :: "('k ⇒ 'k) ⇒ 't ⇒ 't"
where "map_component f v = term_of_pair (pp_of_term v, f (component_of_term v))"
lemma pair_of_map_component [term_simps]:
"pair_of_term (map_component f v) = (pp_of_term v, f (component_of_term v))"
by (simp add: map_component_def pair_term)
lemma pp_of_map_component [term_simps]: "pp_of_term (map_component f v) = pp_of_term v"
by (simp add: pp_of_term_def pair_of_map_component)
lemma component_of_map_component [term_simps]:
"component_of_term (map_component f v) = f (component_of_term v)"
by (simp add: component_of_term_def pair_of_map_component)
lemma map_component_term_of_pair [term_simps]:
"map_component f (term_of_pair (t, k)) = term_of_pair (t, f k)"
by (simp add: map_component_def term_simps)
lemma map_component_comp: "map_component f (map_component g x) = map_component (λk. f (g k)) x"
by (simp add: map_component_def term_simps)
lemma map_component_id [term_simps]: "map_component (λk. k) x = x"
by (simp add: map_component_def term_simps)
lemma map_component_inj:
assumes "inj f" and "map_component f u = map_component f v"
shows "u = v"
proof -
from assms(2) have "term_of_pair (pp_of_term u, f (component_of_term u)) =
term_of_pair (pp_of_term v, f (component_of_term v))"
by (simp only: map_component_def)
hence "(pp_of_term u, f (component_of_term u)) = (pp_of_term v, f (component_of_term v))"
by (rule term_of_pair_injective)
hence 1: "pp_of_term u = pp_of_term v" and "f (component_of_term u) = f (component_of_term v)" by simp_all
from assms(1) this(2) have "component_of_term u = component_of_term v" by (rule injD)
with 1 show ?thesis by (metis term_of_pair_pair)
qed
end
subsection ‹Gr\"obner Bases of Syzygy Modules›
locale gd_inf_term =
gd_term pair_of_term term_of_pair ord ord_strict ord_term ord_term_strict
for pair_of_term::"'t ⇒ ('a::graded_dickson_powerprod × nat)"
and term_of_pair::"('a × nat) ⇒ 't"
and ord::"'a ⇒ 'a ⇒ bool" (infixl "≼" 50)
and ord_strict (infixl "≺" 50)
and ord_term::"'t ⇒ 't ⇒ bool" (infixl "≼⇩t" 50)
and ord_term_strict::"'t ⇒ 't ⇒ bool" (infixl "≺⇩t" 50)
begin
text ‹In order to compute a Gr\"obner basis of the syzygy module of a list ‹bs› of polynomials, one
first needs to ``lift'' ‹bs› to a new list ‹bs'› by adding further components, compute a Gr\"obner
basis ‹gs› of ‹bs'›, and then filter out those elements of ‹gs› whose only non-zero components are
those that were newly added to ‹bs›.
Function ‹init_syzygy_list› takes care of constructing ‹bs'›, and function ‹filter_syzygy_basis›
does the filtering. Function ‹proj_orig_basis›, finally, projects the Gr\"obner basis ‹gs› of ‹bs'›
to a Gr\"obner basis of the original list ‹bs›.›
definition lift_poly_syz :: "nat ⇒ ('t ⇒⇩0 'b) ⇒ nat ⇒ ('t ⇒⇩0 'b::semiring_1)"
where "lift_poly_syz n b i = Abs_poly_mapping
(λx. if pair_of_term x = (0, i) then 1
else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x)
else 0)"
definition proj_poly_syz :: "nat ⇒ ('t ⇒⇩0 'b) ⇒ ('t ⇒⇩0 'b::semiring_1)"
where "proj_poly_syz n b = Poly_Mapping.map_key (λx. map_component (λk. k + n) x) b"
definition cofactor_list_syz :: "nat ⇒ ('t ⇒⇩0 'b) ⇒ ('a ⇒⇩0 'b::semiring_1) list"
where "cofactor_list_syz n b = map (λi. proj_poly i b) [0..<n]"
definition init_syzygy_list :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::semiring_1) list"
where "init_syzygy_list bs = map_idx (lift_poly_syz (length bs)) bs 0"
definition proj_orig_basis :: "nat ⇒ ('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::semiring_1) list"
where "proj_orig_basis n bs = map (proj_poly_syz n) bs"
definition filter_syzygy_basis :: "nat ⇒ ('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::semiring_1) list"
where "filter_syzygy_basis n bs = [b←bs. component_of_term ` keys b ⊆ {0..<n}]"
definition syzygy_module_list :: "('t ⇒⇩0 'b) list ⇒ ('t ⇒⇩0 'b::comm_ring_1) set"
where "syzygy_module_list bs = atomize_poly ` idx_pm_of_pm bs ` pmdl.syzygy_module (set bs)"
subsubsection ‹@{const lift_poly_syz}›
lemma keys_lift_poly_syz_aux:
"{x. (if pair_of_term x = (0, i) then 1
else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x)
else 0) ≠ 0} ⊆ insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b)"
(is "?l ⊆ ?r") for b::"'t ⇒⇩0 'b::semiring_1"
proof
fix x::'t
assume "x ∈ ?l"
hence "(if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0) ≠ 0"
by simp
hence "pair_of_term x = (0, i) ∨ (n ≤ component_of_term x ∧ lookup b (map_component (λk. k - n) x) ≠ 0)"
by (simp split: if_split_asm)
thus "x ∈ ?r"
proof
assume "pair_of_term x = (0, i)"
hence "(0, i) = pair_of_term x" by (rule sym)
hence "x = term_of_pair (0, i)" by (simp add: term_pair)
thus ?thesis by simp
next
assume "n ≤ component_of_term x ∧ lookup b (map_component (λk. k - n) x) ≠ 0"
hence "n ≤ component_of_term x" and 2: "map_component (λk. k - n) x ∈ keys b"
by (auto simp: in_keys_iff)
from this(1) have 3: "map_component (λk. k - n + n) x = x" by (simp add: map_component_def term_simps)
from 2 have "map_component (λk. k + n) (map_component (λk. k - n) x) ∈ map_component (λk. k + n) ` keys b"
by (rule imageI)
with 3 have "x ∈ map_component (λk. k + n) ` keys b" by (simp add: map_component_comp)
thus ?thesis by simp
qed
qed
lemma lookup_lift_poly_syz:
"lookup (lift_poly_syz n b i) =
(λx. if pair_of_term x = (0, i) then 1 else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x) else 0)"
unfolding lift_poly_syz_def
proof (rule Abs_poly_mapping_inverse)
from finite_keys have "finite (map_component (λk. k + n) ` keys b)" ..
hence "finite (insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b))" by (rule finite.insertI)
with keys_lift_poly_syz_aux
have "finite {x. (if pair_of_term x = (0, i) then 1
else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x)
else 0) ≠ 0}"
by (rule finite_subset)
thus "(λx. if pair_of_term x = (0, i) then 1
else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x)
else 0) ∈
{f. finite {x. f x ≠ 0}}" by simp
qed
corollary lookup_lift_poly_syz_alt:
"lookup (lift_poly_syz n b i) (term_of_pair (t, j)) =
(if (t, j) = (0, i) then 1 else if n ≤ j then lookup b (term_of_pair (t, j - n)) else 0)"
by (simp only: lookup_lift_poly_syz term_simps)
lemma keys_lift_poly_syz:
"keys (lift_poly_syz n b i) = insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b)"
proof
have "keys (lift_poly_syz n b i) ⊆
{x. (if pair_of_term x = (0, i) then 1
else if n ≤ component_of_term x then lookup b (map_component (λk. k - n) x)
else 0) ≠ 0}"
(is "_ ⊆ ?A")
proof
fix x
assume "x ∈ keys (lift_poly_syz n b i)"
hence "lookup (lift_poly_syz n b i) x ≠ 0" by (simp add: in_keys_iff)
thus "x ∈ ?A" by (simp add: lookup_lift_poly_syz)
qed
also note keys_lift_poly_syz_aux
finally show "keys (lift_poly_syz n b i) ⊆ insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b)" .
next
show "insert (term_of_pair (0, i)) (map_component (λk. k + n) ` keys b) ⊆ keys (lift_poly_syz n b i)"
proof (simp, rule)
have "lookup (lift_poly_syz n b i) (term_of_pair (0, i)) ≠ 0" by (simp add: lookup_lift_poly_syz_alt)
thus "term_of_pair (0, i) ∈ keys (lift_poly_syz n b i)" by (simp add: in_keys_iff)
next
show "map_component (λk. k + n) ` keys b ⊆ keys (lift_poly_syz n b i)"
proof (rule, elim imageE, simp)
fix x
assume "x ∈ keys b"
hence "lookup (lift_poly_syz n b i) (map_component (λk. k + n) x) ≠ 0"
by (simp add: in_keys_iff lookup_lift_poly_syz_alt map_component_def term_simps)
thus "map_component (λk. k + n) x ∈ keys (lift_poly_syz n b i)" by (simp add: in_keys_iff)
qed
qed
qed
subsubsection ‹@{const proj_poly_syz}›
lemma inj_map_component_plus: "inj (map_component (λk. k + n))"
proof (rule injI)
fix x y
have "inj (λk::nat. k + n)" by (simp add: inj_def)
moreover assume "map_component (λk. k + n) x = map_component (λk. k + n) y"
ultimately show "x = y" by (rule map_component_inj)
qed
lemma lookup_proj_poly_syz: "lookup (proj_poly_syz n p) x = lookup p (map_component (λk. k + n) x)"
by (simp add: proj_poly_syz_def map_key.rep_eq[OF inj_map_component_plus])
lemma lookup_proj_poly_syz_alt:
"lookup (proj_poly_syz n p) (term_of_pair (t, i)) = lookup p (term_of_pair (t, i + n))"
by (simp add: lookup_proj_poly_syz map_component_term_of_pair)
lemma keys_proj_poly_syz: "keys (proj_poly_syz n p) = map_component (λk. k + n) -` keys p"
by (simp add: proj_poly_syz_def keys_map_key[OF inj_map_component_plus])
lemma proj_poly_syz_zero [simp]: "proj_poly_syz n 0 = 0"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly_syz)
lemma proj_poly_syz_plus: "proj_poly_syz n (p + q) = proj_poly_syz n p + proj_poly_syz n q"
by (simp add: proj_poly_syz_def map_key_plus[OF inj_map_component_plus])
lemma proj_poly_syz_sum: "proj_poly_syz n (sum f A) = (∑a∈A. proj_poly_syz n (f a))"
by (rule fun_sum_commute, simp_all add: proj_poly_syz_plus)
lemma proj_poly_syz_sum_list: "proj_poly_syz n (sum_list xs) = sum_list (map (proj_poly_syz n) xs)"
by (rule fun_sum_list_commute, simp_all add: proj_poly_syz_plus)
lemma proj_poly_syz_monom_mult:
"proj_poly_syz n (monom_mult c t p) = monom_mult c t (proj_poly_syz n p)"
by (rule poly_mapping_eqI,
simp add: lookup_proj_poly_syz lookup_monom_mult term_simps adds_pp_def sminus_def)
lemma proj_poly_syz_mult_scalar:
"proj_poly_syz n (mult_scalar q p) = mult_scalar q (proj_poly_syz n p)"
by (rule fun_mult_scalar_commute, simp_all add: proj_poly_syz_plus proj_poly_syz_monom_mult)
lemma proj_poly_syz_lift_poly_syz:
assumes "i < n"
shows "proj_poly_syz n (lift_poly_syz n p i) = p"
proof (rule poly_mapping_eqI, simp add: lookup_proj_poly_syz lookup_lift_poly_syz term_simps map_component_comp,
rule, elim conjE)
fix x::'t
assume "component_of_term x + n = i"
hence "n ≤ i" by simp
with assms show "lookup p x = 1" by simp
qed
lemma proj_poly_syz_eq_zero_iff: "proj_poly_syz n p = 0 ⟷ (component_of_term ` keys p ⊆ {0..<n})"
unfolding keys_eq_empty[symmetric] keys_proj_poly_syz
proof
assume "map_component (λk. k + n) -` keys p = {}" (is "?A = {}")
show "component_of_term ` keys p ⊆ {0..<n}"
proof (rule, rule ccontr)
fix i
assume "i ∈ component_of_term ` keys p"
then obtain x where x: "x ∈ keys p" and i: "i = component_of_term x" ..
assume "i ∉ {0..<n}"
hence "i - n + n = i" by simp
hence 1: "map_component (λk. k - n + n) x = x" by (simp add: map_component_def i term_simps)
have "map_component (λk. k - n) x ∈ ?A" by (rule vimageI2, simp add: map_component_comp x 1)
thus False by (simp add: ‹?A = {}›)
qed
next
assume a: "component_of_term ` keys p ⊆ {0..<n}"
show "map_component (λk. k + n) -` keys p = {}" (is "?A = {}")
proof (rule ccontr)
assume "?A ≠ {}"
then obtain x where "x ∈ ?A" by blast
hence "map_component (λk. k + n) x ∈ keys p" by (rule vimageD)
with a have "component_of_term (map_component (λk. k + n) x) ∈ {0..<n}" by blast
thus False by (simp add: term_simps)
qed
qed
lemma component_of_lt_ge:
assumes "is_pot_ord" and "proj_poly_syz n p ≠ 0"
shows "n ≤ component_of_term (lt p)"
proof -
from assms(2) have "¬ component_of_term ` keys p ⊆ {0..<n}" by (simp add: proj_poly_syz_eq_zero_iff)
then obtain i where "i ∈ component_of_term ` keys p" and "i ∉ {0..<n}" by fastforce
from this(1) obtain x where "x ∈ keys p" and i: "i = component_of_term x" ..
from this(1) have "x ≼⇩t lt p" by (rule lt_max_keys)
with assms(1) have "component_of_term x ≤ component_of_term (lt p)" by (rule is_pot_ordD2)
with ‹i ∉ {0..<n}› show ?thesis by (simp add: i)
qed
lemma lt_proj_poly_syz:
assumes "is_pot_ord" and "proj_poly_syz n p ≠ 0"
shows "lt (proj_poly_syz n p) = map_component (λk. k - n) (lt p)" (is "_ = ?l")
proof -
from component_of_lt_ge[OF assms]
have "component_of_term (lt p) - n + n = component_of_term (lt p)" by simp
hence eq: "map_component (λk. k - n + n) (lt p) = lt p" by (simp add: map_component_def term_simps)
show ?thesis
proof (rule lt_eqI)
have "lookup (proj_poly_syz n p) ?l = lc p"
by (simp add: lc_def lookup_proj_poly_syz term_simps map_component_comp eq)
also have "... ≠ 0"
proof (rule lc_not_0, rule)
assume "p = 0"
hence "proj_poly_syz n p = 0" by simp
with assms(2) show False ..
qed
finally show "lookup (proj_poly_syz n p) ?l ≠ 0" .
next
fix x
assume "lookup (proj_poly_syz n p) x ≠ 0"
hence "map_component (λk. k + n) x ∈ keys p" by (simp add: in_keys_iff lookup_proj_poly_syz)
hence "map_component (λk. k + n) x ≼⇩t lt p" by (rule lt_max_keys)
with assms(1) show "x ≼⇩t ?l" by (auto simp add: is_pot_ord term_simps)
qed
qed
lemma proj_proj_poly_syz: "proj_poly k (proj_poly_syz n p) = proj_poly (k + n) p"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_proj_poly_syz_alt)
lemma poly_mapping_eqI_proj_syz:
assumes "proj_poly_syz n p = proj_poly_syz n q"
and "⋀k. k < n ⟹ proj_poly k p = proj_poly k q"
shows "p = q"
proof (rule poly_mapping_eqI_proj)
fix k
show "proj_poly k p = proj_poly k q"
proof (cases "k < n")
case True
thus ?thesis by (rule assms(2))
next
case False
have "proj_poly (k - n + n) p = proj_poly (k - n + n) q"
by (simp only: proj_proj_poly_syz[symmetric] assms(1))
with False show ?thesis by simp
qed
qed
subsubsection ‹@{const cofactor_list_syz}›
lemma length_cofactor_list_syz [simp]: "length (cofactor_list_syz n p) = n"
by (simp add: cofactor_list_syz_def)
lemma cofactor_list_syz_nth:
assumes "i < n"
shows "(cofactor_list_syz n p) ! i = proj_poly i p"
by (simp add: cofactor_list_syz_def map_idx_nth assms)
lemma cofactor_list_syz_zero [simp]: "cofactor_list_syz n 0 = replicate n 0"
by (rule nth_equalityI, simp_all add: cofactor_list_syz_nth proj_zero)
lemma cofactor_list_syz_plus:
"cofactor_list_syz n (p + q) = map2 (+) (cofactor_list_syz n p) (cofactor_list_syz n q)"
by (rule nth_equalityI, simp_all add: cofactor_list_syz_nth proj_plus)
subsubsection ‹@{const init_syzygy_list}›
lemma length_init_syzygy_list [simp]: "length (init_syzygy_list bs) = length bs"
by (simp add: init_syzygy_list_def)
lemma init_syzygy_list_nth:
assumes "i < length bs"
shows "(init_syzygy_list bs) ! i = lift_poly_syz (length bs) (bs ! i) i"
by (simp add: init_syzygy_list_def map_idx_nth[OF assms])
lemma Keys_init_syzygy_list:
"Keys (set (init_syzygy_list bs)) =
map_component (λk. k + length bs) ` Keys (set bs) ∪ (λi. term_of_pair (0, i)) ` {0..<length bs}"
proof -
have eq1: "(⋃b∈set bs. map_component (λk. k + length bs) ` keys b) =
(⋃i∈{0..<length bs}. map_component (λk. k + length bs) ` keys (bs ! i))"
by (fact UN_upt[symmetric])
have eq2: "(λi. term_of_pair (0, i)) ` {0..<length bs} = (⋃i∈{0..<length bs}. {term_of_pair (0, i)})"
by auto
show ?thesis
by (simp add: init_syzygy_list_def set_map_idx Keys_def keys_lift_poly_syz image_UN
eq1 eq2 UN_Un_distrib[symmetric])
qed
lemma pp_of_Keys_init_syzygy_list_subset:
"pp_of_term ` Keys (set (init_syzygy_list bs)) ⊆ insert 0 (pp_of_term ` Keys (set bs))"
by (auto simp add: Keys_init_syzygy_list image_Un rev_image_eqI term_simps)
lemma pp_of_Keys_init_syzygy_list_superset:
"pp_of_term ` Keys (set bs) ⊆ pp_of_term ` Keys (set (init_syzygy_list bs))"
by (simp add: Keys_init_syzygy_list image_Un term_simps image_image)
lemma pp_of_Keys_init_syzygy_list:
assumes "bs ≠ []"
shows "pp_of_term ` Keys (set (init_syzygy_list bs)) = insert 0 (pp_of_term ` Keys (set bs))"
proof
show "insert 0 (pp_of_term ` Keys (set bs)) ⊆ pp_of_term ` Keys (set (init_syzygy_list bs))"
proof (simp add: pp_of_Keys_init_syzygy_list_superset)
from assms have "{0..<length bs} ≠ {}" by auto
hence "Pair 0 ` {0..<length bs} ≠ {}" by blast
then obtain x::'t where x: "x ∈ (λi. term_of_pair (0, i)) ` {0..<length bs}" by blast
hence "pp_of_term ` (λi. term_of_pair (0, i)) ` {0..<length bs} = {pp_of_term x}"
using image_subset_iff by (auto simp: term_simps)
also from x have "... = {0}" using pp_of_term_of_pair by auto
finally show "0 ∈ pp_of_term ` Keys (set (init_syzygy_list bs))"
by (simp add: Keys_init_syzygy_list image_Un)
qed
qed (fact pp_of_Keys_init_syzygy_list_subset)
lemma component_of_Keys_init_syzygy_list:
"component_of_term ` Keys (set (init_syzygy_list bs)) =
(+) (length bs) ` component_of_term ` Keys (set bs) ∪ {0..<length bs}"
by (simp add: Keys_init_syzygy_list image_Un image_comp o_def ac_simps term_simps)
lemma proj_lift_poly_syz:
assumes "j < n"
shows "proj_poly j (lift_poly_syz n p i) = (1 when j = i)"
proof (simp add: when_def, intro conjI impI)
assume "j = i"
with assms have "¬ n ≤ i" by simp
show "proj_poly i (lift_poly_syz n p i) = 1"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_lift_poly_syz_alt ‹¬ n ≤ i› lookup_one)
next
assume "j ≠ i"
from assms have "¬ n ≤ j" by simp
show "proj_poly j (lift_poly_syz n p i) = 0"
by (rule poly_mapping_eqI, simp add: lookup_proj_poly lookup_lift_poly_syz_alt ‹¬ n ≤ j› ‹j ≠ i›)
qed
subsubsection ‹@{const proj_orig_basis}›
lemma length_proj_orig_basis [simp]: "length (proj_orig_basis n bs) = length bs"
by (simp add: proj_orig_basis_def)
lemma proj_orig_basis_nth:
assumes "i < length bs"
shows "(proj_orig_basis n bs) ! i = proj_poly_syz n (bs ! i)"
by (simp add: proj_orig_basis_def assms)
lemma proj_orig_basis_init_syzygy_list [simp]:
"proj_orig_basis (length bs) (init_syzygy_list bs) = bs"
by (rule nth_equalityI, simp_all add: init_syzygy_list_nth proj_orig_basis_nth proj_poly_syz_lift_poly_syz)
lemma set_proj_orig_basis: "set (proj_orig_basis n bs) = proj_poly_syz n ` set bs"
by (simp add: proj_orig_basis_def)
text ‹The following lemma could be generalized from @{const proj_poly_syz} to arbitrary module homomorphisms,
i.\,e. functions respecting ‹0›, addition and scalar multiplication.›
lemma pmdl_proj_orig_basis':
"pmdl (set (proj_orig_basis n bs)) = proj_poly_syz n ` pmdl (set bs)" (is "?A = ?B")
proof
show "?A ⊆ ?B"
proof
fix p
assume "p ∈ pmdl (set (proj_orig_basis n bs))"
thus "p ∈ proj_poly_syz n ` pmdl (set bs)"
proof (induct rule: pmdl_induct)
case module_0
have "0 = proj_poly_syz n 0" by simp
also from pmdl.span_zero have "... ∈ proj_poly_syz n ` pmdl (set bs)" by (rule imageI)
finally show ?case .
next
case (module_plus p b c t)
from module_plus(2) obtain q where "q ∈ pmdl (set bs)" and p: "p = proj_poly_syz n q" ..
from module_plus(3) obtain a where "a ∈ set bs" and b: "b = proj_poly_syz n a"
unfolding set_proj_orig_basis ..
have "p + monom_mult c t b = proj_poly_syz n (q + monom_mult c t a)"
by (simp add: p b proj_poly_syz_monom_mult proj_poly_syz_plus)
also have "... ∈ proj_poly_syz n ` pmdl (set bs)"
proof (rule imageI, rule pmdl.span_add)
show "monom_mult c t a ∈ pmdl (set bs)"
by (rule pmdl_closed_monom_mult, rule pmdl.span_base, fact)
qed fact
finally show ?case .
qed
qed
next
show "?B ⊆ ?A"
proof
fix p
assume "p ∈ proj_poly_syz n ` pmdl (set bs)"
then obtain q where "q ∈ pmdl (set bs)" and p: "p = proj_poly_syz n q" ..
from this(1) show "p ∈ pmdl (set (proj_orig_basis n bs))" unfolding p
proof (induct rule: pmdl_induct)
case module_0
have "proj_poly_syz n 0 = 0" by simp
also have "... ∈ pmdl (set (proj_orig_basis n bs))" by (fact pmdl.span_zero)
finally show ?case .
next
case (module_plus q b c t)
have "proj_poly_syz n (q + monom_mult c t b) =
proj_poly_syz n q + monom_mult c t (proj_poly_syz n b)"
by (simp add: proj_poly_syz_plus proj_poly_syz_monom_mult)
also have "... ∈ pmdl (set (proj_orig_basis n bs))"
proof (rule pmdl.span_add)
show "monom_mult c t (proj_poly_syz n b) ∈ pmdl (set (proj_orig_basis n bs))"
proof (rule pmdl_closed_monom_mult, rule pmdl.span_base)
show "proj_poly_syz n b ∈ set (proj_orig_basis n bs)"
by (simp add: set_proj_orig_basis, rule imageI, fact)
qed
qed fact
finally show ?case .
qed
qed
qed
subsubsection ‹@{const filter_syzygy_basis}›
lemma filter_syzygy_basis_alt: "filter_syzygy_basis n bs = [b←bs. proj_poly_syz n b = 0]"
by (simp add: filter_syzygy_basis_def proj_poly_syz_eq_zero_iff)
lemma set_filter_syzygy_basis:
"set (filter_syzygy_basis n bs) = {b∈set bs. proj_poly_syz n b = 0}"
by (simp add: filter_syzygy_basis_alt)
subsubsection ‹@{const syzygy_module_list}›
lemma syzygy_module_listI:
assumes "s' ∈ pmdl.syzygy_module (set bs)" and "s = atomize_poly (idx_pm_of_pm bs s')"
shows "s ∈ syzygy_module_list bs"
unfolding assms(2) syzygy_module_list_def by (intro imageI, fact assms(1))
lemma syzygy_module_listE:
assumes "s ∈ syzygy_module_list bs"
obtains s' where "s' ∈ pmdl.syzygy_module (set bs)" and "s = atomize_poly (idx_pm_of_pm bs s')"
using assms unfolding syzygy_module_list_def by (elim imageE, simp)
lemma monom_mult_atomize:
"monom_mult c t (atomize_poly p) = atomize_poly (MPoly_Type_Class.punit.monom_mult (monomial c t) 0 p)"
by (rule poly_mapping_eqI_proj, simp add: proj_monom_mult proj_atomize_poly
MPoly_Type_Class.punit.lookup_monom_mult times_monomial_left)
lemma punit_monom_mult_monomial_idx_pm_of_pm:
"MPoly_Type_Class.punit.monom_mult (monomial c t) (0::nat) (idx_pm_of_pm bs s) =
idx_pm_of_pm bs (MPoly_Type_Class.punit.monom_mult (monomial c t) (0::'t ⇒⇩0 'b::ring_1) s)"
by (rule poly_mapping_eqI, simp add: MPoly_Type_Class.punit.lookup_monom_mult lookup_idx_pm_of_pm when_def)
lemma syzygy_module_list_closed_monom_mult:
assumes "s ∈ syzygy_module_list bs"
shows "monom_mult c t s ∈ syzygy_module_list bs"
proof -
from assms obtain s' where s': "s' ∈ pmdl.syzygy_module (set bs)"
and s: "s = atomize_poly (idx_pm_of_pm bs s')" by (rule syzygy_module_listE)
show ?thesis unfolding s
proof (rule syzygy_module_listI)
from s' show "(monomial c t) ⋅ s' ∈ pmdl.syzygy_module (set bs)"
by (rule syzygy_module_closed_map_scale)
next
show "monom_mult c t (atomize_poly (idx_pm_of_pm bs s')) =
atomize_poly (idx_pm_of_pm bs ((monomial c t) ⋅ s'))"
by (simp add: monom_mult_atomize punit_monom_mult_monomial_idx_pm_of_pm
MPoly_Type_Class.punit.map_scale_eq_monom_mult)
qed
qed
lemma pmdl_syzygy_module_list [simp]: "pmdl (syzygy_module_list bs) = syzygy_module_list bs"
proof (rule pmdl_idI)
show "0 ∈ syzygy_module_list bs"
by (rule syzygy_module_listI, fact pmdl.zero_in_syzygy_module, simp add: atomize_zero)
next
fix s1 s2
assume "s1 ∈ syzygy_module_list bs"
then obtain s1' where s1': "s1' ∈ pmdl.syzygy_module (set bs)"
and s1: "s1 = atomize_poly (idx_pm_of_pm bs s1')" by (rule syzygy_module_listE)
assume "s2 ∈ syzygy_module_list bs"
then obtain s2' where s2': "s2' ∈ pmdl.syzygy_module (set bs)"
and s2: "s2 = atomize_poly (idx_pm_of_pm bs s2')" by (rule syzygy_module_listE)
show "s1 + s2 ∈ syzygy_module_list bs"
proof (rule syzygy_module_listI)
from s1' s2' show "s1' + s2' ∈ pmdl.syzygy_module (set bs)"
by (rule pmdl.syzygy_module_closed_plus)
next
show "s1 + s2 = atomize_poly (idx_pm_of_pm bs (s1' + s2'))"
by (simp add: idx_pm_of_pm_plus atomize_plus s1 s2)
qed
qed (fact syzygy_module_list_closed_monom_mult)
text ‹The following lemma also holds without the distinctness constraint on ‹bs›, but then the
proof becomes more difficult.›
lemma syzygy_module_listI':
assumes "distinct bs" and "sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs) = 0"
and "component_of_term ` keys s ⊆ {0..<length bs}"
shows "s ∈ syzygy_module_list bs"
proof (rule syzygy_module_listI)
show "pm_of_idx_pm bs (vectorize_poly s) ∈ pmdl.syzygy_module (set bs)"
proof (rule pmdl.syzygy_moduleI, rule pmdl.representsI)
have "(∑v∈keys (pm_of_idx_pm bs (vectorize_poly s)).
mult_scalar (lookup (pm_of_idx_pm bs (vectorize_poly s)) v) v) =
(∑b∈set bs. mult_scalar (lookup (pm_of_idx_pm bs (vectorize_poly s)) b) b)"
by (rule sum.mono_neutral_left, fact finite_set, fact keys_pm_of_idx_pm_subset, simp add: in_keys_iff)
also have "... = sum_list (map (λb. mult_scalar (lookup (pm_of_idx_pm bs (vectorize_poly s)) b) b) bs)"
by (simp only: sum_code distinct_remdups_id[OF assms(1)])
also have "... = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs)"
proof (rule arg_cong[of _ _ sum_list], rule nth_equalityI, simp_all)
fix i
assume "i < length bs"
with assms(1) have "lookup (pm_of_idx_pm bs (vectorize_poly s)) (bs ! i) =
cofactor_list_syz (length bs) s ! i"
by (simp add: lookup_pm_of_idx_pm_distinct[OF assms(1)] cofactor_list_syz_nth lookup_vectorize_poly)
thus "mult_scalar (lookup (pm_of_idx_pm bs (vectorize_poly s)) (bs ! i)) (bs ! i) =
mult_scalar (cofactor_list_syz (length bs) s ! i) (bs ! i)" by (simp only:)
qed
also have "... = 0" by (fact assms(2))
finally show "pmdl.rep (pm_of_idx_pm bs (vectorize_poly s)) = 0" by (simp only: pmdl.rep_def)
qed (fact keys_pm_of_idx_pm_subset)
next
from assms(3) have "keys (vectorize_poly s) ⊆ {0..<length bs}" by (simp add: keys_vectorize_poly)
with assms(1) have "idx_pm_of_pm bs (pm_of_idx_pm bs (vectorize_poly s)) = vectorize_poly s"
by (rule idx_pm_of_pm_of_idx_pm)
thus "s = atomize_poly (idx_pm_of_pm bs (pm_of_idx_pm bs (vectorize_poly s)))"
by (simp add: atomize_vectorize_poly)
qed
lemma component_of_syzygy_module_list:
assumes "s ∈ syzygy_module_list bs"
shows "component_of_term ` keys s ⊆ {0..<length bs}"
proof -
from assms obtain s' where s: "s = atomize_poly (idx_pm_of_pm bs s')"
by (rule syzygy_module_listE)
have "component_of_term ` keys s ⊆ (⋃x∈{0..<length bs}. {x})"
by (simp only: s keys_atomize_poly image_UN, rule UN_mono, fact keys_idx_pm_of_pm_subset, auto simp: term_simps)
also have "... = {0..<length bs}" by simp
finally show ?thesis .
qed
lemma map2_mult_scalar_proj_poly_syz:
"map2 mult_scalar xs (map (proj_poly_syz n) ys) =
map (proj_poly_syz n ∘ (λ(x, y). mult_scalar x y)) (zip xs ys)"
by (rule nth_equalityI, simp_all add: proj_poly_syz_mult_scalar)
lemma map2_times_proj:
"map2 (*) xs (map (proj_poly k) ys) = map (proj_poly k ∘ (λ(x, y). x ⊙ y)) (zip xs ys)"
by (rule nth_equalityI, simp_all add: proj_mult_scalar)
text ‹Probably the following lemma also holds without the distinctness constraint on ‹bs›.›
lemma syzygy_module_list_subset:
assumes "distinct bs"
shows "syzygy_module_list bs ⊆ pmdl (set (init_syzygy_list bs))"
proof
let ?as = "init_syzygy_list bs"
fix s
assume "s ∈ syzygy_module_list bs"
then obtain s' where s': "s' ∈ pmdl.syzygy_module (set bs)"
and s: "s = atomize_poly (idx_pm_of_pm bs s')" by (rule syzygy_module_listE)
from s' have "pmdl.represents (set bs) s' 0" by (rule pmdl.syzygy_moduleD)
hence "keys s' ⊆ set bs" and 1: "0 = pmdl.rep s'"
by (rule pmdl.representsD1, rule pmdl.representsD2)
have "s = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) (init_syzygy_list bs))"
(is "_ = ?r")
proof (rule poly_mapping_eqI_proj_syz)
have "proj_poly_syz (length bs) ?r =
sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s)
(map (proj_poly_syz (length bs)) (init_syzygy_list bs)))"
by (simp add: proj_poly_syz_sum_list map2_mult_scalar_proj_poly_syz)
also have "... = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs)"
by (simp add: proj_orig_basis_def[symmetric])
also have "... = sum_list (map (λb. mult_scalar (lookup s' b) b) bs)"
proof (rule arg_cong[of _ _ sum_list], rule nth_equalityI, simp_all)
fix i
assume "i < length bs"
with assms(1) have "lookup s' (bs ! i) = cofactor_list_syz (length bs) s ! i"
by (simp add: s cofactor_list_syz_nth lookup_idx_pm_of_pm proj_atomize_poly)
thus "mult_scalar (cofactor_list_syz (length bs) s ! i) (bs ! i) =
mult_scalar (lookup s' (bs ! i)) (bs ! i)" by (simp only:)
qed
also have "... = (∑b∈set bs. mult_scalar (lookup s' b) b)"
by (simp only: sum_code distinct_remdups_id[OF assms])
also have "... = (∑v∈keys s'. mult_scalar (lookup s' v) v)"
by (rule sum.mono_neutral_right, fact finite_set, fact, simp add: in_keys_iff)
also have "... = 0" by (simp add: 1 pmdl.rep_def)
finally have eq: "proj_poly_syz (length bs) ?r = 0" .
show "proj_poly_syz (length bs) s = proj_poly_syz (length bs) ?r"
by (simp add: eq ‹s ∈ syzygy_module_list bs› proj_poly_syz_eq_zero_iff component_of_syzygy_module_list)
next
fix k
assume "k < length bs"
have "proj_poly k s = map2 (*) (cofactor_list_syz (length bs) s) (map (proj_poly k)
(init_syzygy_list bs)) ! k"
by (simp add: ‹k < length bs› init_syzygy_list_nth proj_lift_poly_syz cofactor_list_syz_nth)
also have "... = sum_list (map2 (*) (cofactor_list_syz (length bs) s)
(map (proj_poly k) (init_syzygy_list bs)))"
by (rule sum_list_eq_nthI[symmetric],
simp_all add: ‹k < length bs› init_syzygy_list_nth proj_lift_poly_syz)
also have "... = proj_poly k ?r"
by (simp add: proj_sum_list map2_times_proj)
finally show "proj_poly k s = proj_poly k ?r" .
qed
also have "… ∈ pmdl (set (init_syzygy_list bs))" by (fact pmdl.span_listI)
finally show "s ∈ pmdl (set (init_syzygy_list bs))" .
qed
subsubsection ‹Cofactors›
lemma map2_mult_scalar_plus:
"map2 (⊙) (map2 (+) xs ys) zs = map2 (+) (map2 (⊙) xs zs) (map2 (⊙) ys zs)"
by (rule nth_equalityI, simp_all add: mult_scalar_distrib_right)
lemma syz_cofactors:
assumes "p ∈ pmdl (set (init_syzygy_list bs))"
shows "proj_poly_syz (length bs) p = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) p) bs)"
using assms
proof (induct rule: pmdl_induct)
case module_0
show ?case by (simp, rule sum_list_zeroI', simp)
next
case (module_plus p b c t)
from this(3) obtain i where i: "i < length bs" and b: "b = (init_syzygy_list bs) ! i"
unfolding length_init_syzygy_list[symmetric, of bs] by (metis in_set_conv_nth)
have "proj_poly_syz (length bs) (p + monom_mult c t b) =
proj_poly_syz (length bs) p + monom_mult c t (bs ! i)"
by (simp only: proj_poly_syz_plus proj_poly_syz_monom_mult b init_syzygy_list_nth[OF i]
proj_poly_syz_lift_poly_syz[OF i])
also have "... = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) p) bs) +
monom_mult c t (bs ! i)" by (simp only: module_plus(2))
also have "... = sum_list (map2 mult_scalar (cofactor_list_syz (length bs) (p + monom_mult c t b)) bs)"
proof (simp add: cofactor_list_syz_plus map2_mult_scalar_plus sum_list_map2_plus)
have proj_b: "j < length bs ⟹ proj_poly j b = (1 when j = i)" for j
by (simp add: b init_syzygy_list_nth i proj_lift_poly_syz)
have eq: "j < length bs ⟹ (map2 mult_scalar (cofactor_list_syz (length bs) (monom_mult c t b)) bs) ! j =
(monom_mult c t (bs ! i) when j = i)" for j
by (simp add: cofactor_list_syz_nth proj_monom_mult proj_b mult_scalar_monom_mult when_def)
have "sum_list (map2 mult_scalar (cofactor_list_syz (length bs) (monom_mult c t b)) bs) =
(map2 mult_scalar (cofactor_list_syz (length bs) (monom_mult c t b)) bs) ! i"
by (rule sum_list_eq_nthI, simp add: i, simp add: eq del: nth_zip nth_map)
also have "... = mult_scalar (punit.monom_mult c t (proj_poly i b)) (bs ! i)"
by (simp add: i cofactor_list_syz_nth proj_monom_mult)
also have "... = monom_mult c t (bs ! i)"
by (simp add: proj_b i mult_scalar_monomial times_monomial_left[symmetric])
finally show "monom_mult c t (bs ! i) =
sum_list (map2 mult_scalar (cofactor_list_syz (length bs) (monom_mult c t b)) bs)"
by (simp only:)
qed
finally show ?case .
qed
subsubsection ‹Modules›
lemma pmdl_proj_orig_basis:
assumes "pmdl (set gs) = pmdl (set (init_syzygy_list bs))"
shows "pmdl (set (proj_orig_basis (length bs) gs)) = pmdl (set bs)"
by (simp add: pmdl_proj_orig_basis' assms,
simp only: pmdl_proj_orig_basis'[symmetric] proj_orig_basis_init_syzygy_list)
lemma pmdl_filter_syzygy_basis_subset:
assumes "distinct bs" and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))"
shows "pmdl (set (filter_syzygy_basis (length bs) gs)) ⊆ pmdl (syzygy_module_list bs)"
proof (rule pmdl.span_mono, rule)
fix s
assume "s ∈ set (filter_syzygy_basis (length bs) gs)"
hence "s ∈ set gs" and eq: "proj_poly_syz (length bs) s = 0"
by (simp_all add: set_filter_syzygy_basis)
from this(1) have "s ∈ pmdl (set gs)" by (rule pmdl.span_base)
hence "s ∈ pmdl (set (init_syzygy_list bs))" by (simp only: assms)
hence "proj_poly_syz (length bs) s =
sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs)"
by (rule syz_cofactors)
hence "distinct bs" and "sum_list (map2 mult_scalar (cofactor_list_syz (length bs) s) bs) = 0"
by (simp_all only: eq assms(1))
moreover from eq have "component_of_term ` keys s ⊆ {0..<length bs}" by (simp only: proj_poly_syz_eq_zero_iff)
ultimately show "s ∈ syzygy_module_list bs" by (rule syzygy_module_listI')
qed
lemma ex_filter_syzygy_basis_adds_lt:
assumes "is_pot_ord" and "distinct bs" and "is_Groebner_basis (set gs)"
and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))"
and "f ∈ pmdl (syzygy_module_list bs)" and "f ≠ 0"
shows "∃g∈set (filter_syzygy_basis (length bs) gs). g ≠ 0 ∧ lt g adds⇩t lt f"
proof -
from assms(5) have "f ∈ syzygy_module_list bs" by simp
also from assms(2) have "... ⊆ pmdl (set (init_syzygy_list bs))"
by (rule syzygy_module_list_subset)
also have "... = pmdl (set gs)" by (simp only: assms(4))
finally have "f ∈ pmdl (set gs)" .
with assms(3, 6) obtain g where "g ∈ set gs" and "g ≠ 0"
and adds: "lt g adds⇩t lt f" unfolding GB_alt_3_finite[OF finite_set] by blast
show ?thesis
proof (intro bexI conjI)
show "g ∈ set (filter_syzygy_basis (length bs) gs)"
proof (simp add: set_filter_syzygy_basis, rule)
show "proj_poly_syz (length bs) g = 0"
proof (rule ccontr)
assume "proj_poly_syz (length bs) g ≠ 0"
with assms(1) have "length bs ≤ component_of_term (lt g)" by (rule component_of_lt_ge)
also from adds have "... = component_of_term (lt f)" by (simp add: adds_term_def)
also have "... < length bs"
proof -
from ‹f ≠ 0› have "lt f ∈ keys f" by (rule lt_in_keys)
hence "component_of_term (lt f) ∈ component_of_term ` keys f" by (rule imageI)
also from ‹f ∈ syzygy_module_list bs› have "... ⊆ {0..<length bs}"
by (rule component_of_syzygy_module_list)
finally show "component_of_term (lt f) < length bs" by simp
qed
finally show False ..
qed
qed fact
qed fact+
qed
lemma pmdl_filter_syzygy_basis:
fixes bs::"('t ⇒⇩0 'b::field) list"
assumes "is_pot_ord" and "distinct bs" and "is_Groebner_basis (set gs)" and
"pmdl (set gs) = pmdl (set (init_syzygy_list bs))"
shows "pmdl (set (filter_syzygy_basis (length bs) gs)) = syzygy_module_list bs"
proof -
from finite_set
have "pmdl (set (filter_syzygy_basis (length bs) gs)) = pmdl (syzygy_module_list bs)"
proof (rule pmdl_eqI_adds_lt_finite)
from assms(2, 4)
show "pmdl (set (filter_syzygy_basis (length bs) gs)) ⊆ pmdl (syzygy_module_list bs)"
by (rule pmdl_filter_syzygy_basis_subset)
next
fix f
assume "f ∈ pmdl (syzygy_module_list bs)" and "f ≠ 0"
with assms show "∃g∈set (filter_syzygy_basis (length bs) gs). g ≠ 0 ∧ lt g adds⇩t lt f"
by (rule ex_filter_syzygy_basis_adds_lt)
qed
thus ?thesis by simp
qed
subsubsection ‹Gr\"obner Bases›
lemma proj_orig_basis_isGB:
assumes "is_pot_ord" and "is_Groebner_basis (set gs)" and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))"
shows "is_Groebner_basis (set (proj_orig_basis (length bs) gs))"
unfolding GB_alt_3_finite[OF finite_set]
proof (intro ballI impI)
fix f
assume "f ∈ pmdl (set (proj_orig_basis (length bs) gs))"
also have "... = proj_poly_syz (length bs) ` pmdl (set gs)" by (fact pmdl_proj_orig_basis')
finally obtain h where "h ∈ pmdl (set gs)" and f: "f = proj_poly_syz (length bs) h" ..
assume "f ≠ 0"
with assms(1) have ltf: "lt f = map_component (λk. k - length bs) (lt h)" unfolding f
by (rule lt_proj_poly_syz)
from ‹f ≠ 0› have "h ≠ 0" by (auto simp add: f)
with assms(2) ‹h ∈ pmdl (set gs)› obtain g where "g ∈ set gs" and "g ≠ 0"
and "lt g adds⇩t lt h" unfolding GB_alt_3_finite[OF finite_set] by blast
from this(3) have 1: "component_of_term (lt g) = component_of_term (lt h)"
and 2: "pp_of_term (lt g) adds pp_of_term (lt h)" by (simp_all add: adds_term_def)
let ?g = "proj_poly_syz (length bs) g"
have "?g ≠ 0"
proof (simp add: proj_poly_syz_eq_zero_iff, rule)
assume "component_of_term ` keys g ⊆ {0..<length bs}"
from assms(1) ‹f ≠ 0› have "length bs ≤ component_of_term (lt h)"
unfolding f by (rule component_of_lt_ge)
hence "component_of_term (lt g) ∉ {0..<length bs}" by (simp add: 1)
moreover from ‹g ≠ 0› have "lt g ∈ keys g" by (rule lt_in_keys)
ultimately show False using ‹component_of_term ` keys g ⊆ {0..<length bs}› by blast
qed
with assms(1) have ltg: "lt ?g = map_component (λk. k - length bs) (lt g)" by (rule lt_proj_poly_syz)
show "∃g∈set (proj_orig_basis (length bs) gs). g ≠ 0 ∧ lt g adds⇩t lt f"
proof (intro bexI conjI)
show "lt ?g adds⇩t lt f" by (simp add: ltf ltg adds_term_def 1 2 term_simps)
next
show "?g ∈ set (proj_orig_basis (length bs) gs)"
unfolding set_proj_orig_basis using ‹g ∈ set gs› by (rule imageI)
qed fact
qed
lemma filter_syzygy_basis_isGB:
assumes "is_pot_ord" and "distinct bs" and "is_Groebner_basis (set gs)"
and "pmdl (set gs) = pmdl (set (init_syzygy_list bs))"
shows "is_Groebner_basis (set (filter_syzygy_basis (length bs) gs))"
unfolding GB_alt_3_finite[OF finite_set]
proof (intro ballI impI)
fix f::"'t ⇒⇩0 'b"
assume "f ≠ 0"
assume "f ∈ pmdl (set (filter_syzygy_basis (length bs) gs))"
also from assms have "... = syzygy_module_list bs" by (rule pmdl_filter_syzygy_basis)
finally have "f ∈ pmdl (syzygy_module_list bs)" by simp
from assms this ‹f ≠ 0›
show "∃g∈set (filter_syzygy_basis (length bs) gs). g ≠ 0 ∧ lt g adds⇩t lt f"
by (rule ex_filter_syzygy_basis_adds_lt)
qed
end
end
Theory Syzygy_Examples
section ‹Sample Computations of Syzygies›
theory Syzygy_Examples
imports Buchberger Algorithm_Schema_Impl Syzygy Code_Target_Rat
begin
subsection ‹Preparations›
text ‹We must define the following four constants outside the global interpretation, since otherwise
their types are too general.›
definition splus_pprod :: "('a::nat, 'b::nat) pp ⇒ _"
where "splus_pprod = pprod.splus"
definition monom_mult_pprod :: "'c::semiring_0 ⇒ ('a::nat, 'b::nat) pp ⇒ ((('a, 'b) pp × nat) ⇒⇩0 'c) ⇒ _"
where "monom_mult_pprod = pprod.monom_mult"
definition mult_scalar_pprod :: "(('a::nat, 'b::nat) pp ⇒⇩0 'c::semiring_0) ⇒ ((('a, 'b) pp × nat) ⇒⇩0 'c) ⇒ _"
where "mult_scalar_pprod = pprod.mult_scalar"
definition adds_term_pprod :: "(('a::nat, 'b::nat) pp × _) ⇒ _"
where "adds_term_pprod = pprod.adds_term"
lemma (in gd_term) compute_trd_aux [code]:
"trd_aux fs p r =
(if is_zero p then
r
else
case find_adds fs (lt p) of
None ⇒ trd_aux fs (tail p) (plus_monomial_less r (lc p) (lt p))
| Some f ⇒ trd_aux fs (tail p - monom_mult (lc p / lc f) (lp p - lp f) (tail f)) r
)"
by (simp only: trd_aux.simps[of fs p r] plus_monomial_less_def is_zero_def)
locale gd_nat_inf_term = gd_nat_term pair_of_term term_of_pair cmp_term
for pair_of_term::"'t::nat_term ⇒ ('a::{nat_term,graded_dickson_powerprod} × nat)"
and term_of_pair::"('a × nat) ⇒ 't"
and cmp_term
begin
sublocale aux: gd_inf_term pair_of_term term_of_pair
"λs t. le_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
"λs t. lt_of_nat_term_order cmp_term (term_of_pair (s, the_min)) (term_of_pair (t, the_min))"
"le_of_nat_term_order cmp_term"
"lt_of_nat_term_order cmp_term" ..
definition lift_keys :: "nat ⇒ ('t, 'b) oalist_ntm ⇒ ('t, 'b::semiring_0) oalist_ntm"
where "lift_keys i xs = oalist_of_list_ntm (map_raw (λkv. (map_component ((+) i) (fst kv), snd kv)) (list_of_oalist_ntm xs))"
lemma list_of_oalist_lift_keys:
"list_of_oalist_ntm (lift_keys i xs) = (map_raw (λkv. (map_component ((+) i) (fst kv), snd kv)) (list_of_oalist_ntm xs))"
unfolding lift_keys_def oops
text ‹Regardless of whether the above lemma holds (which might be the case) or not, we can use
@{const lift_keys} in computations. Now, however, it is implemented rather inefficiently, because
the list resulting from the application of @{const map_raw} is sorted again. That should not be
a big problem though, since @{const lift_keys} is applied only once to every input polynomial
before computing syzygies.›
lemma lookup_lift_keys_plus:
"lookup (MP_oalist (lift_keys i xs)) (term_of_pair (t, i + k)) = lookup (MP_oalist xs) (term_of_pair (t, k))"
(is "?l = ?r")
proof -
let ?f = "λkv::'t × 'b. (map_component ((+) i) (fst kv), snd kv)"
obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce
from oalist_inv_list_of_oalist_ntm[of xs] have inv: "ko_ntm.oalist_inv_raw ox xs'"
by (simp add: xs ko_ntm.oalist_inv_def nat_term_compare_inv_conv)
let ?rel = "ko.lt (key_order_of_nat_term_order_inv ox)"
have "irreflp ?rel" by (simp add: irreflp_def)
moreover have "transp ?rel" by (simp add: lt_of_nat_term_order_alt)
moreover from oa_ntm.list_of_oalist_sorted[of xs]
have "sorted_wrt (ko.lt (key_order_of_nat_term_order_inv ox)) (map fst xs')" by (simp add: xs)
ultimately have dist1: "distinct (map fst xs')" by (rule distinct_sorted_wrt_irrefl)
have 1: "u = v" if "map_component ((+) i) u = map_component ((+) i) v" for u v
proof -
have "inj ((+) i)" by (simp add: inj_def)
thus ?thesis using that by (rule map_component_inj)
qed
have dist2: "distinct (map fst (map_pair (λkv. (map_component ((+) i) (fst kv), snd kv)) xs'))"
by (rule ko_ntm.distinct_map_pair, fact dist1, simp add: 1)
have "?l = lookup_dflt (map_pair ?f xs') (term_of_pair (t, i + k))"
by (simp add: oa_ntm.lookup_def lift_keys_def xs oalist_of_list_ntm_def list_of_oalist_OAlist_ntm
ko_ntm.lookup_pair_sort_oalist'[OF dist2])
also have "... = lookup_dflt (map_pair ?f xs') (fst (?f (term_of_pair (t, k), b)))"
by (simp add: map_component_term_of_pair)
also have "... = snd (?f (term_of_pair (t, k), lookup_dflt xs' (term_of_pair (t, k))))"
by (rule ko_ntm.lookup_dflt_map_pair, fact dist1, auto intro: 1)
also have "... = ?r" by (simp add: oa_ntm.lookup_def xs ko_ntm.lookup_dflt_eq_lookup_pair[OF inv])
finally show ?thesis .
qed
lemma keys_lift_keys_subset:
"keys (MP_oalist (lift_keys i xs)) ⊆ (map_component ((+) i)) ` keys (MP_oalist xs)" (is "?l ⊆ ?r")
proof -
let ?f = "λkv::'t × 'b. (map_component ((+) i) (fst kv), snd kv)"
obtain xs' ox where xs: "list_of_oalist_ntm xs = (xs', ox)" by fastforce
let ?rel = "ko.lt (key_order_of_nat_term_order_inv ox)"
have "irreflp ?rel" by (simp add: irreflp_def)
moreover have "transp ?rel" by (simp add: lt_of_nat_term_order_alt)
moreover from oa_ntm.list_of_oalist_sorted[of xs]
have "sorted_wrt (ko.lt (key_order_of_nat_term_order_inv ox)) (map fst xs')" by (simp add: xs)
ultimately have dist1: "distinct (map fst xs')" by (rule distinct_sorted_wrt_irrefl)
have 1: "u = v" if "map_component ((+) i) u = map_component ((+) i) v" for u v
proof -
have "inj ((+) i)" by (simp add: inj_def)
thus ?thesis using that by (rule map_component_inj)
qed
have dist2: "distinct (map fst (map_pair (λkv. (map_component ((+) i) (fst kv), snd kv)) xs'))"
by (rule ko_ntm.distinct_map_pair, fact dist1, simp add: 1)
have "?l ⊆ fst ` set (fst (map_raw ?f (list_of_oalist_ntm xs)))"
by (auto simp: keys_MP_oalist lift_keys_def oalist_of_list_ntm_def list_of_oalist_OAlist_ntm xs
ko_ntm.set_sort_oalist[OF dist2])
also from ko_ntm.map_raw_subset have "... ⊆ fst ` ?f ` set (fst (list_of_oalist_ntm xs))"
by (rule image_mono)
also have "... ⊆ ?r" by (simp add: keys_MP_oalist image_image)
finally show ?thesis .
qed
end
global_interpretation pprod': gd_nat_inf_term "λx::('a, 'b) pp × nat. x" "λx. x" cmp_term
rewrites "pprod.pp_of_term = fst"
and "pprod.component_of_term = snd"
and "pprod.splus = splus_pprod"
and "pprod.monom_mult = monom_mult_pprod"
and "pprod.mult_scalar = mult_scalar_pprod"
and "pprod.adds_term = adds_term_pprod"
for cmp_term :: "(('a::nat, 'b::nat) pp × nat) nat_term_order"
defines shift_map_keys_pprod = pprod'.shift_map_keys
and lift_keys_pprod = pprod'.lift_keys
and min_term_pprod = pprod'.min_term
and lt_pprod = pprod'.lt
and lc_pprod = pprod'.lc
and tail_pprod = pprod'.tail
and comp_opt_p_pprod = pprod'.comp_opt_p
and ord_p_pprod = pprod'.ord_p
and ord_strict_p_pprod = pprod'.ord_strict_p
and find_adds_pprod = pprod'.find_adds
and trd_aux_pprod= pprod'.trd_aux
and trd_pprod = pprod'.trd
and spoly_pprod = pprod'.spoly
and count_const_lt_components_pprod = pprod'.count_const_lt_components
and count_rem_components_pprod = pprod'.count_rem_components
and const_lt_component_pprod = pprod'.const_lt_component
and full_gb_pprod = pprod'.full_gb
and keys_to_list_pprod = pprod'.keys_to_list
and Keys_to_list_pprod = pprod'.Keys_to_list
and add_pairs_single_sorted_pprod = pprod'.add_pairs_single_sorted
and add_pairs_pprod = pprod'.add_pairs
and canon_pair_order_aux_pprod = pprod'.canon_pair_order_aux
and canon_basis_order_pprod = pprod'.canon_basis_order
and new_pairs_sorted_pprod = pprod'.new_pairs_sorted
and component_crit_pprod = pprod'.component_crit
and chain_ncrit_pprod = pprod'.chain_ncrit
and chain_ocrit_pprod = pprod'.chain_ocrit
and apply_icrit_pprod = pprod'.apply_icrit
and apply_ncrit_pprod = pprod'.apply_ncrit
and apply_ocrit_pprod = pprod'.apply_ocrit
and trdsp_pprod = pprod'.trdsp
and gb_sel_pprod = pprod'.gb_sel
and gb_red_aux_pprod = pprod'.gb_red_aux
and gb_red_pprod = pprod'.gb_red
and gb_aux_pprod = pprod'.gb_aux
and gb_pprod = pprod'.gb
and filter_syzygy_basis_pprod = pprod'.aux.filter_syzygy_basis
and init_syzygy_list_pprod = pprod'.aux.init_syzygy_list
and lift_poly_syz_pprod = pprod'.aux.lift_poly_syz
and map_component_pprod = pprod'.map_component
subgoal by (rule gd_nat_inf_term.intro, fact gd_nat_term_id)
subgoal by (fact pprod_pp_of_term)
subgoal by (fact pprod_component_of_term)
subgoal by (simp only: splus_pprod_def)
subgoal by (simp only: monom_mult_pprod_def)
subgoal by (simp only: mult_scalar_pprod_def)
subgoal by (simp only: adds_term_pprod_def)
done
lemma compute_adds_term_pprod [code]:
"adds_term_pprod u v = (snd u = snd v ∧ adds_pp_add_linorder (fst u) (fst v))"
by (simp add: adds_term_pprod_def pprod.adds_term_def adds_pp_add_linorder_def)
lemma compute_splus_pprod [code]: "splus_pprod t (s, i) = (t + s, i)"
by (simp add: splus_pprod_def pprod.splus_def)
lemma compute_shift_map_keys_pprod [code abstract]:
"list_of_oalist_ntm (shift_map_keys_pprod t f xs) = map_raw (λ(k, v). (splus_pprod t k, f v)) (list_of_oalist_ntm xs)"
by (simp add: pprod'.list_of_oalist_shift_keys case_prod_beta')
lemma compute_trd_pprod [code]: "trd_pprod to fs p = trd_aux_pprod to fs p (change_ord to 0)"
by (simp only: pprod'.trd_def change_ord_def)
lemmas [code] = conversep_iff
lemma POT_is_pot_ord: "pprod'.is_pot_ord (TYPE('a::nat)) (TYPE('b::nat)) (POT to)"
by (rule pprod'.is_pot_ordI, simp add: lt_of_nat_term_order nat_term_compare_POT pot_comp rep_nat_term_prod_def,
simp add: comparator_of_def)
definition Vec⇩0 :: "nat ⇒ (('a, nat) pp ⇒⇩0 'b) ⇒ (('a::nat, nat) pp × nat) ⇒⇩0 'b::semiring_1" where
"Vec⇩0 i p = mult_scalar_pprod p (Poly_Mapping.single (0, i) 1)"
definition "syzygy_basis to bs =
filter_syzygy_basis_pprod (length bs) (map fst (gb_pprod (POT to) (map (λp. (p, ())) (init_syzygy_list_pprod bs)) ()))"
thm pprod'.aux.filter_syzygy_basis_isGB[OF POT_is_pot_ord]
lemma lift_poly_syz_MP_oalist [code]:
"lift_poly_syz_pprod n (MP_oalist xs) i = MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))"
proof (rule poly_mapping_eqI, simp add: pprod'.aux.lookup_lift_poly_syz del: MP_oalist.rep_eq, intro conjI impI)
fix v::"('a, 'b) pp × nat"
assume "n ≤ snd v"
moreover obtain t k where "v = (t, k)" by fastforce
ultimately have k: "n + (k - n) = k" by simp
hence v: "v = (t, n + (k - n))" by (simp only: ‹v = (t, k)›)
assume "v ≠ (0, i)"
hence "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v =
lookup (MP_oalist (lift_keys_pprod n xs)) v" by (simp add: oa_ntm.lookup_insert)
also have "... = lookup (MP_oalist xs) (t, k - n)" by (simp only: v pprod'.lookup_lift_keys_plus)
also have "... = lookup (MP_oalist xs) (map_component_pprod (λk. k - n) v)"
by (simp add: v pprod'.map_component_term_of_pair)
finally show "lookup (MP_oalist xs) (map_component_pprod (λk. k - n) v) =
lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v" by (rule HOL.sym)
next
fix v::"('a, 'b) pp × nat"
assume "¬ n ≤ snd v"
assume "v ≠ (0, i)"
hence "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v =
lookup (MP_oalist (lift_keys_pprod n xs)) v" by (simp add: add: oa_ntm.lookup_insert)
also have "... = 0"
proof (rule ccontr)
assume "lookup (MP_oalist (lift_keys_pprod n xs)) v ≠ 0"
hence "v ∈ keys (MP_oalist (lift_keys_pprod n xs))" by (simp add: in_keys_iff del: MP_oalist.rep_eq)
also have "... ⊆ map_component_pprod ((+) n) ` keys (MP_oalist xs)"
by (fact pprod'.keys_lift_keys_subset)
finally obtain u where "v = map_component_pprod ((+) n) u" ..
hence "snd v = n + snd u" by (simp add: pprod'.component_of_map_component)
with ‹¬ n ≤ snd v› show False by simp
qed
finally show "lookup (MP_oalist (OAlist_insert_ntm ((0, i), 1) (lift_keys_pprod n xs))) v = 0" .
qed (simp_all add: oa_ntm.lookup_insert)
subsection ‹Computations›
experiment begin interpretation trivariate⇩0_rat .
lemma
"syzygy_basis DRLEX [Vec⇩0 0 (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y), Vec⇩0 0 (X * Y * Z + 2 * Y⇧2)] =
[Vec⇩0 0 (C⇩0 (1 / 3) * X * Y * Z + C⇩0 (2 / 3) * Y⇧2) + Vec⇩0 1 (C⇩0 (- 1 / 3) * X⇧2 * Z ^ 3 - X⇧2 * Y)]"
by eval
value [code] "syzygy_basis DRLEX [Vec⇩0 0 (X⇧2 * Z ^ 3 + 3 * X⇧2 * Y), Vec⇩0 0 (X * Y * Z + 2 * Y⇧2), Vec⇩0 0 (X - Y + 3 * Z)]"
lemma
"map fst (gb_pprod (POT DRLEX) (map (λp. (p, ())) (init_syzygy_list_pprod
[Vec⇩0 0 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 0 (Y ^ 3 + 2 * X * Z), Vec⇩0 0 (Z⇧2 - X - Y)])) ()) =
[
Vec⇩0 0 1 + Vec⇩0 3 (X ^ 4 + 3 * X⇧2 * Y),
Vec⇩0 1 1 + Vec⇩0 3 (Y ^ 3 + 2 * X * Z),
Vec⇩0 0 (Y ^ 3 + 2 * X * Z) - Vec⇩0 1 (X ^ 4 + 3 * X⇧2 * Y),
Vec⇩0 2 1 + Vec⇩0 3 (Z⇧2 - X - Y),
Vec⇩0 1 (Z⇧2 - X - Y) - Vec⇩0 2 (Y ^ 3 + 2 * X * Z),
Vec⇩0 0 (Z⇧2 - X - Y) - Vec⇩0 2 (X ^ 4 + 3 * X⇧2 * Y),
Vec⇩0 0 (- (Y ^ 3 * Z⇧2) + Y ^ 4 + X * Y ^ 3 + 2 * X⇧2 * Z + 2 * X * Y * Z - 2 * X * Z ^ 3) +
Vec⇩0 1 (X ^ 4 * Z⇧2 - X ^ 5 - X ^ 4 * Y - 3 * X ^ 3 * Y - 3 * X⇧2 * Y⇧2 + 3 * X⇧2 * Y * Z⇧2)
]"
by eval
lemma
"syzygy_basis DRLEX [Vec⇩0 0 (X ^ 4 + 3 * X⇧2 * Y), Vec⇩0 0 (Y ^ 3 + 2 * X * Z), Vec⇩0 0 (Z⇧2 - X - Y)] =
[
Vec⇩0 0 (Y ^ 3 + 2 * X * Z) - Vec⇩0 1 (X ^ 4 + 3 * X⇧2 * Y),
Vec⇩0 1 (Z⇧2 - X - Y) - Vec⇩0 2 (Y ^ 3 + 2 * X * Z),
Vec⇩0 0 (Z⇧2 - X - Y) - Vec⇩0 2 (X ^ 4 + 3 * X⇧2 * Y),
Vec⇩0 0 (- (Y ^ 3 * Z⇧2) + Y ^ 4 + X * Y ^ 3 + 2 * X⇧2 * Z + 2 * X * Y * Z - 2 * X * Z ^ 3) +
Vec⇩0 1 (X ^ 4 * Z⇧2 - X ^ 5 - X ^ 4 * Y - 3 * X ^ 3 * Y - 3 * X⇧2 * Y⇧2 + 3 * X⇧2 * Y * Z⇧2)
]"
by eval
value [code] "syzygy_basis DRLEX [Vec⇩0 0 (X * Y - Z), Vec⇩0 0 (X * Z - Y), Vec⇩0 0 (Y * Z - X)]"
lemma
"map fst (gb_pprod (POT DRLEX) (map (λp. (p, ())) (init_syzygy_list_pprod
[Vec⇩0 0 (X * Y - Z), Vec⇩0 0 (X * Z - Y), Vec⇩0 0 (Y * Z - X)])) ()) =
[
Vec⇩0 0 1 + Vec⇩0 3 (X * Y - Z),
Vec⇩0 1 1 + Vec⇩0 3 (X * Z - Y),
Vec⇩0 2 1 + Vec⇩0 3 (Y * Z - X),
Vec⇩0 0 (- X * Z + Y) + Vec⇩0 1 (X * Y - Z),
Vec⇩0 0 (- Y * Z + X) + Vec⇩0 2 (X * Y - Z),
Vec⇩0 1 (- Y * Z + X) + Vec⇩0 2 (X * Z - Y),
Vec⇩0 1 (-Y) + Vec⇩0 2 (X) + Vec⇩0 3 (Y ^ 2 - X ^ 2),
Vec⇩0 0 (Z) + Vec⇩0 2 (-X) + Vec⇩0 3 (X ^ 2 - Z ^ 2),
Vec⇩0 0 (Y - Y * Z ^ 2) + Vec⇩0 1 (Y ^ 2 * Z - Z) + Vec⇩0 2 (Y ^ 2 - Z ^ 2),
Vec⇩0 0 (- Y) + Vec⇩0 1 (- (X * Y)) + Vec⇩0 2 (X ^ 2 - 1) + Vec⇩0 3 (X - X ^ 3)
]"
by eval
lemma
"syzygy_basis DRLEX [Vec⇩0 0 (X * Y - Z), Vec⇩0 0 (X * Z - Y), Vec⇩0 0 (Y * Z - X)] =
[
Vec⇩0 0 (- X * Z + Y) + Vec⇩0 1 (X * Y - Z),
Vec⇩0 0 (- Y * Z + X) + Vec⇩0 2 (X * Y - Z),
Vec⇩0 1 (- Y * Z + X) + Vec⇩0 2 (X * Z - Y),
Vec⇩0 0 (Y - Y * Z ^ 2) + Vec⇩0 1 (Y ^ 2 * Z - Z) + Vec⇩0 2 (Y ^ 2 - Z ^ 2)
]"
by eval
end
end
Theory Groebner_PM
theory Groebner_PM
imports Polynomials.MPoly_PM Reduced_GB
begin
text ‹We prove results that hold specifically for Gr\"obner bases in polynomial rings, where the
polynomials really have @{emph ‹indeterminates›}.›
context pm_powerprod
begin
lemmas finite_reduced_GB_Polys =
punit.finite_reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_is_reduced_GB_Polys =
punit.reduced_GB_is_reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_is_GB_Polys =
punit.reduced_GB_is_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_is_auto_reduced_Polys =
punit.reduced_GB_is_auto_reduced_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_is_monic_set_Polys =
punit.reduced_GB_is_monic_set_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_nonzero_Polys =
punit.reduced_GB_nonzero_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_ideal_Polys =
punit.reduced_GB_pmdl_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_unique_Polys =
punit.reduced_GB_unique_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas reduced_GB_Polys =
punit.reduced_GB_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
lemmas ideal_eq_UNIV_iff_reduced_GB_eq_one_Polys =
ideal_eq_UNIV_iff_reduced_GB_eq_one_dgrad_p_set[simplified, OF dickson_grading_varnum, where m=0, simplified dgrad_p_set_varnum]
subsection ‹Univariate Polynomials›
lemma (in -) adds_univariate_linear:
assumes "finite X" and "card X ≤ 1" and "s ∈ .[X]" and "t ∈ .[X]"
obtains "s adds t" | "t adds s"
proof (cases "s adds t")
case True
thus ?thesis ..
next
case False
then obtain x where 1: "lookup t x < lookup s x" by (auto simp: adds_poly_mapping le_fun_def not_le)
hence "x ∈ keys s" by (simp add: in_keys_iff)
also from assms(3) have "… ⊆ X" by (rule PPsD)
finally have "x ∈ X" .
have "t adds s" unfolding adds_poly_mapping le_fun_def
proof
fix y
show "lookup t y ≤ lookup s y"
proof (cases "y ∈ keys t")
case True
also from assms(4) have "keys t ⊆ X" by (rule PPsD)
finally have "y ∈ X" .
with assms(1, 2) ‹x ∈ X› have "x = y" by (simp add: card_le_Suc0_iff_eq)
with 1 show ?thesis by simp
next
case False
thus ?thesis by (simp add: in_keys_iff)
qed
qed
thus ?thesis ..
qed
context
fixes X :: "'x set"
assumes fin_X: "finite X" and card_X: "card X ≤ 1"
begin
lemma ord_iff_adds_univariate:
assumes "s ∈ .[X]" and "t ∈ .[X]"
shows "s ≼ t ⟷ s adds t"
proof
assume "s ≼ t"
from fin_X card_X assms show "s adds t"
proof (rule adds_univariate_linear)
assume "t adds s"
hence "t ≼ s" by (rule ord_adds)
with ‹s ≼ t› have "s = t"
by simp
thus ?thesis by simp
qed
qed (rule ord_adds)
lemma adds_iff_deg_le_univariate:
assumes "s ∈ .[X]" and "t ∈ .[X]"
shows "s adds t ⟷ deg_pm s ≤ deg_pm t"
proof
assume *: "deg_pm s ≤ deg_pm t"
from fin_X card_X assms show "s adds t"
proof (rule adds_univariate_linear)
assume "t adds s"
hence "t = s" using * by (rule adds_deg_pm_antisym)
thus ?thesis by simp
qed
qed (rule deg_pm_mono)
corollary ord_iff_deg_le_univariate: "s ∈ .[X] ⟹ t ∈ .[X] ⟹ s ≼ t ⟷ deg_pm s ≤ deg_pm t"
by (simp only: ord_iff_adds_univariate adds_iff_deg_le_univariate)
lemma poly_deg_univariate:
assumes "p ∈ P[X]"
shows "poly_deg p = deg_pm (lpp p)"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
hence lp_in: "lpp p ∈ keys p" by (rule punit.lt_in_keys)
also from assms have "… ⊆ .[X]" by (rule PolysD)
finally have "lpp p ∈ .[X]" .
show ?thesis
proof (intro antisym poly_deg_leI)
fix t
assume "t ∈ keys p"
hence "t ≼ lpp p" by (rule punit.lt_max_keys)
moreover from ‹t ∈ keys p› ‹keys p ⊆ .[X]› have "t ∈ .[X]" ..
ultimately show "deg_pm t ≤ deg_pm (lpp p)" using ‹lpp p ∈ .[X]›
by (simp only: ord_iff_deg_le_univariate)
next
from lp_in show "deg_pm (lpp p) ≤ poly_deg p" by (rule poly_deg_max_keys)
qed
qed
lemma reduced_GB_univariate_cases:
assumes "F ⊆ P[X]"
obtains g where "g ∈ P[X]" and "g ≠ 0" and "lcf g = 1" and "punit.reduced_GB F = {g}" |
"punit.reduced_GB F = {}"
proof (cases "punit.reduced_GB F = {}")
case True
thus ?thesis ..
next
case False
let ?G = "punit.reduced_GB F"
from fin_X assms have ar: "punit.is_auto_reduced ?G" and "0 ∉ ?G" and "?G ⊆ P[X]"
and m: "punit.is_monic_set ?G"
by (rule reduced_GB_is_auto_reduced_Polys, rule reduced_GB_nonzero_Polys, rule reduced_GB_Polys,
rule reduced_GB_is_monic_set_Polys)
from False obtain g where "g ∈ ?G" by blast
with ‹0 ∉ ?G› ‹?G ⊆ P[X]› have "g ≠ 0" and "g ∈ P[X]" by blast+
from this(1) have lp_g: "lpp g ∈ keys g" by (rule punit.lt_in_keys)
also from ‹g ∈ P[X]› have "… ⊆ .[X]" by (rule PolysD)
finally have "lpp g ∈ .[X]" .
note ‹g ∈ P[X]› ‹g ≠ 0›
moreover from m ‹g ∈ ?G› ‹g ≠ 0› have "lcf g = 1" by (rule punit.is_monic_setD)
moreover have "?G = {g}"
proof
show "?G ⊆ {g}"
proof
fix g'
assume "g' ∈ ?G"
with ‹0 ∉ ?G› ‹?G ⊆ P[X]› have "g' ≠ 0" and "g' ∈ P[X]" by blast+
from this(1) have lp_g': "lpp g' ∈ keys g'" by (rule punit.lt_in_keys)
also from ‹g' ∈ P[X]› have "… ⊆ .[X]" by (rule PolysD)
finally have "lpp g' ∈ .[X]" .
have "g' = g"
proof (rule ccontr)
assume "g' ≠ g"
with ‹g ∈ ?G› ‹g' ∈ ?G› have g: "g ∈ ?G - {g'}" and g': "g' ∈ ?G - {g}" by blast+
from fin_X card_X ‹lpp g ∈ .[X]› ‹lpp g' ∈ .[X]› show False
proof (rule adds_univariate_linear)
assume *: "lpp g adds lpp g'"
from ar ‹g' ∈ ?G› have "¬ punit.is_red (?G - {g'}) g'" by (rule punit.is_auto_reducedD)
moreover from g ‹g ≠ 0› lp_g' * have "punit.is_red (?G - {g'}) g'"
by (rule punit.is_red_addsI[simplified])
ultimately show ?thesis ..
next
assume *: "lpp g' adds lpp g"
from ar ‹g ∈ ?G› have "¬ punit.is_red (?G - {g}) g" by (rule punit.is_auto_reducedD)
moreover from g' ‹g' ≠ 0› lp_g * have "punit.is_red (?G - {g}) g"
by (rule punit.is_red_addsI[simplified])
ultimately show ?thesis ..
qed
qed
thus "g' ∈ {g}" by simp
qed
next
from ‹g ∈ ?G› show "{g} ⊆ ?G" by simp
qed
ultimately show ?thesis ..
qed
corollary deg_reduced_GB_univariate_le:
assumes "F ⊆ P[X]" and "f ∈ ideal F" and "f ≠ 0" and "g ∈ punit.reduced_GB F"
shows "poly_deg g ≤ poly_deg f"
using assms(1)
proof (rule reduced_GB_univariate_cases)
let ?G = "punit.reduced_GB F"
fix g'
assume "g' ∈ P[X]" and "g' ≠ 0" and G: "?G = {g'}"
from fin_X assms(1) have gb: "punit.is_Groebner_basis ?G" and "ideal ?G = ideal F"
and "?G ⊆ P[X]"
by (rule reduced_GB_is_GB_Polys, rule reduced_GB_ideal_Polys, rule reduced_GB_Polys)
from assms(2) this(2) have "f ∈ ideal ?G" by simp
with gb obtain g'' where "g'' ∈ ?G" and "lpp g'' adds lpp f"
using assms(3) by (rule punit.GB_adds_lt[simplified])
with assms(4) have "lpp g adds lpp f" by (simp add: G)
hence "deg_pm (lpp g) ≤ deg_pm (lpp f)" by (rule deg_pm_mono)
moreover from assms(4) ‹?G ⊆ P[X]› have "g ∈ P[X]" ..
ultimately have "poly_deg g ≤ deg_pm (lpp f)" by (simp only: poly_deg_univariate)
also from punit.lt_in_keys have "… ≤ poly_deg f" by (rule poly_deg_max_keys) fact
finally show ?thesis .
next
assume "punit.reduced_GB F = {}"
with assms(4) show ?thesis by simp
qed
end
subsection ‹Homogeneity›
lemma is_reduced_GB_homogeneous:
assumes "⋀f. f ∈ F ⟹ homogeneous f" and "punit.is_reduced_GB G" and "ideal G = ideal F"
and "g ∈ G"
shows "homogeneous g"
proof (rule homogeneousI)
fix s t
have 1: "deg_pm u = deg_pm (lpp g)" if "u ∈ keys g" for u
proof -
from assms(4) have "g ∈ ideal G" by (rule ideal.span_base)
hence "g ∈ ideal F" by (simp only: assms(3))
from that have "u ∈ Keys (hom_components g)" by (simp only: Keys_hom_components)
then obtain q where q: "q ∈ hom_components g" and "u ∈ keys q" by (rule in_KeysE)
from assms(1) ‹g ∈ ideal F› q have "q ∈ ideal F" by (rule homogeneous_ideal')
from assms(2) have "punit.is_Groebner_basis G" by (rule punit.reduced_GB_D1)
moreover from ‹q ∈ ideal F› have "q ∈ ideal G" by (simp only: assms(3))
moreover from q have "q ≠ 0" by (rule hom_components_nonzero)
ultimately obtain g' where "g' ∈ G" and "g' ≠ 0" and adds: "lpp g' adds lpp q"
by (rule punit.GB_adds_lt[simplified])
from ‹q ≠ 0› have "lpp q ∈ keys q" by (rule punit.lt_in_keys)
also from q have "… ⊆ Keys (hom_components g)" by (rule keys_subset_Keys)
finally have "lpp q ∈ keys g" by (simp only: Keys_hom_components)
with _ ‹g' ≠ 0› have red: "punit.is_red {g'} g"
using adds by (rule punit.is_red_addsI[simplified]) simp
from assms(2) have "punit.is_auto_reduced G" by (rule punit.reduced_GB_D2)
hence "¬ punit.is_red (G - {g}) g" using assms(4) by (rule punit.is_auto_reducedD)
with red have "¬ {g'} ⊆ G - {g}" using punit.is_red_subset by blast
with ‹g' ∈ G› have "g' = g" by simp
from ‹lpp q ∈ keys g› have "lpp q ≼ lpp g" by (rule punit.lt_max_keys)
moreover from adds have "lpp g ≼ lpp q"
unfolding ‹g' = g› by (rule punit.ord_adds_term[simplified])
ultimately have eq: "lpp q = lpp g"
by simp
from q have "homogeneous q" by (rule hom_components_homogeneous)
hence "deg_pm u = deg_pm (lpp q)"
using ‹u ∈ keys q› ‹lpp q ∈ keys q› by (rule homogeneousD)
thus ?thesis by (simp only: eq)
qed
assume "s ∈ keys g"
hence 2: "deg_pm s = deg_pm (lpp g)" by (rule 1)
assume "t ∈ keys g"
hence "deg_pm t = deg_pm (lpp g)" by (rule 1)
with 2 show "deg_pm s = deg_pm t" by simp
qed
lemma lp_dehomogenize:
assumes "is_hom_ord x" and "homogeneous p"
shows "lpp (dehomogenize x p) = except (lpp p) {x}"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
hence "lpp p ∈ keys p" by (rule punit.lt_in_keys)
with assms(2) have "except (lpp p) {x} ∈ keys (dehomogenize x p)"
by (rule keys_dehomogenizeI)
thus ?thesis
proof (rule punit.lt_eqI_keys)
fix t
assume "t ∈ keys (dehomogenize x p)"
then obtain s where "s ∈ keys p" and t: "t = except s {x}" by (rule keys_dehomogenizeE)
from this(1) have "s ≼ lpp p" by (rule punit.lt_max_keys)
moreover from assms(2) ‹s ∈ keys p› ‹lpp p ∈ keys p› have "deg_pm s = deg_pm (lpp p)"
by (rule homogeneousD)
ultimately show "t ≼ except (lpp p) {x}" using assms(1) by (simp add: t is_hom_ordD)
qed
qed
lemma isGB_dehomogenize:
assumes "is_hom_ord x" and "finite X" and "G ⊆ P[X]" and "punit.is_Groebner_basis G"
and "⋀g. g ∈ G ⟹ homogeneous g"
shows "punit.is_Groebner_basis (dehomogenize x ` G)"
using dickson_grading_varnum
proof (rule punit.isGB_I_adds_lt[simplified])
from assms(2) show "finite (X - {x})" by simp
next
have "dehomogenize x ` G ⊆ P[X - {x}]"
proof
fix g
assume "g ∈ dehomogenize x ` G"
then obtain g' where "g' ∈ G" and g: "g = dehomogenize x g'" ..
from this(1) assms(3) have "g' ∈ P[X]" ..
hence "indets g' ⊆ X" by (rule PolysD)
have "indets g ⊆ indets g' - {x}" by (simp only: g indets_dehomogenize)
also from ‹indets g' ⊆ X› subset_refl have "… ⊆ X - {x}" by (rule Diff_mono)
finally show "g ∈ P[X - {x}]" by (rule PolysI_alt)
qed
thus "dehomogenize x ` G ⊆ punit.dgrad_p_set (varnum (X - {x})) 0"
by (simp only: dgrad_p_set_varnum)
next
fix p
assume "p ∈ ideal (dehomogenize x ` G)"
then obtain G0 q where "G0 ⊆ dehomogenize x ` G" and "finite G0" and p: "p = (∑g∈G0. q g * g)"
by (rule ideal.spanE)
from this(1) obtain G' where "G' ⊆ G" and G0: "G0 = dehomogenize x ` G'"
and inj: "inj_on (dehomogenize x) G'" by (rule subset_imageE_inj)
define p' where "p' = (∑g∈G'. q (dehomogenize x g) * g)"
have "p' ∈ ideal G'" unfolding p'_def by (rule ideal.sum_in_spanI)
also from ‹G' ⊆ G› have "… ⊆ ideal G" by (rule ideal.span_mono)
finally have "p' ∈ ideal G" .
with assms(5) have "homogenize x p' ∈ ideal G" (is "?p ∈ _") by (rule homogeneous_ideal_homogenize)
assume "p ∈ punit.dgrad_p_set (varnum (X - {x})) 0"
hence "p ∈ P[X - {x}]" by (simp only: dgrad_p_set_varnum)
hence "indets p ⊆ X - {x}" by (rule PolysD)
hence "x ∉ indets p" by blast
have "p = dehomogenize x p" by (rule sym) (simp add: ‹x ∉ indets p›)
also from inj have "… = dehomogenize x (∑g∈G'. q (dehomogenize x g) * dehomogenize x g)"
by (simp add: p G0 sum.reindex)
also have "… = dehomogenize x ?p"
by (simp add: dehomogenize_sum dehomogenize_times p'_def)
finally have p: "p = dehomogenize x ?p" .
moreover assume "p ≠ 0"
ultimately have "?p ≠ 0" by (auto simp del: dehomogenize_homogenize)
with assms(4) ‹?p ∈ ideal G› obtain g where "g ∈ G" and "g ≠ 0" and adds: "lpp g adds lpp ?p"
by (rule punit.GB_adds_lt[simplified])
from this(1) have "homogeneous g" by (rule assms(5))
show "∃g∈dehomogenize x ` G. g ≠ 0 ∧ lpp g adds lpp p"
proof (intro bexI conjI notI)
assume "dehomogenize x g = 0"
hence "g = 0" using ‹homogeneous g› by (rule dehomogenize_zeroD)
with ‹g ≠ 0› show False ..
next
from assms(1) ‹homogeneous g› have "lpp (dehomogenize x g) = except (lpp g) {x}"
by (rule lp_dehomogenize)
also from adds have "… adds except (lpp ?p) {x}"
by (simp add: adds_poly_mapping le_fun_def lookup_except)
also from assms(1) homogeneous_homogenize have "… = lpp (dehomogenize x ?p)"
by (rule lp_dehomogenize[symmetric])
finally show "lpp (dehomogenize x g) adds lpp p" by (simp only: p)
next
from ‹g ∈ G› show "dehomogenize x g ∈ dehomogenize x ` G" by (rule imageI)
qed
qed
end
context extended_ord_pm_powerprod
begin
lemma extended_ord_lp:
assumes "None ∉ indets p"
shows "restrict_indets_pp (extended_ord.lpp p) = lpp (restrict_indets p)"
proof (cases "p = 0")
case True
thus ?thesis by simp
next
case False
hence "extended_ord.lpp p ∈ keys p" by (rule extended_ord.punit.lt_in_keys)
hence "restrict_indets_pp (extended_ord.lpp p) ∈ restrict_indets_pp ` keys p" by (rule imageI)
also from assms have eq: "… = keys (restrict_indets p)" by (rule keys_restrict_indets[symmetric])
finally show ?thesis
proof (rule punit.lt_eqI_keys[symmetric])
fix t
assume "t ∈ keys (restrict_indets p)"
then obtain s where "s ∈ keys p" and t: "t = restrict_indets_pp s" unfolding eq[symmetric] ..
from this(1) have "extended_ord s (extended_ord.lpp p)" by (rule extended_ord.punit.lt_max_keys)
thus "t ≼ restrict_indets_pp (extended_ord.lpp p)" by (auto simp: t extended_ord_def)
qed
qed
lemma restrict_indets_reduced_GB:
assumes "finite X" and "F ⊆ P[X]"
shows "punit.is_Groebner_basis (restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F))"
(is ?thesis1)
and "ideal (restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F)) = ideal F"
(is ?thesis2)
and "restrict_indets ` extended_ord.punit.reduced_GB (homogenize None ` extend_indets ` F) ⊆ P[X]"
(is ?thesis3)
proof -
let ?F = "homogenize None ` extend_indets ` F"
let ?G = "extended_ord.punit.reduced_GB ?F"
from assms(1) have "finite (insert None (Some ` X))" by simp
moreover have "?F ⊆ P[insert None (Some ` X)]"
proof
fix hf
assume "hf ∈ ?F"
then obtain f where "f ∈ F" and hf: "hf = homogenize None (extend_indets f)" by auto
from this(1) assms(2) have "f ∈ P[X]" ..
hence "indets f ⊆ X" by (rule PolysD)
hence "Some ` indets f ⊆ Some ` X" by (rule image_mono)
with indets_extend_indets[of f] have "indets (extend_indets f) ⊆ Some ` X" by blast
hence "insert None (indets (extend_indets f)) ⊆ insert None (Some ` X)" by blast
with indets_homogenize_subset have "indets hf ⊆ insert None (Some ` X)"
unfolding hf by (rule subset_trans)
thus "hf ∈ P[insert None (Some ` X)]" by (rule PolysI_alt)
qed
ultimately have G_sub: "?G ⊆ P[insert None (Some ` X)]"
and ideal_G: "ideal ?G = ideal ?F"
and GB_G: "extended_ord.punit.is_reduced_GB ?G"
by (rule extended_ord.reduced_GB_Polys, rule extended_ord.reduced_GB_ideal_Polys,
rule extended_ord.reduced_GB_is_reduced_GB_Polys)
show ?thesis3
proof
fix g
assume "g ∈ restrict_indets ` ?G"
then obtain g' where "g' ∈ ?G" and g: "g = restrict_indets g'" ..
from this(1) G_sub have "g' ∈ P[insert None (Some ` X)]" ..
hence "indets g' ⊆ insert None (Some ` X)" by (rule PolysD)
have "indets g ⊆ the ` (indets g' - {None})" by (simp only: g indets_restrict_indets_subset)
also from ‹indets g' ⊆ insert None (Some ` X)› have "… ⊆ X" by auto
finally show "g ∈ P[X]" by (rule PolysI_alt)
qed
from dickson_grading_varnum show ?thesis1
proof (rule punit.isGB_I_adds_lt[simplified])
from ‹?thesis3› show "restrict_indets ` ?G ⊆ punit.dgrad_p_set (varnum X) 0"
by (simp only: dgrad_p_set_varnum)
next
fix p :: "('a ⇒⇩0 nat) ⇒⇩0 'b"
assume "p ≠ 0"
assume "p ∈ ideal (restrict_indets ` ?G)"
hence "extend_indets p ∈ extend_indets ` ideal (restrict_indets ` ?G)" by (rule imageI)
also have "… ⊆ ideal (extend_indets ` restrict_indets ` ?G)" by (fact extend_indets_ideal_subset)
also have "… = ideal (dehomogenize None ` ?G)"
by (simp only: image_comp extend_indets_comp_restrict_indets)
finally have p_in_ideal: "extend_indets p ∈ ideal (dehomogenize None ` ?G)" .
assume "p ∈ punit.dgrad_p_set (varnum X) 0"
hence "p ∈ P[X]" by (simp only: dgrad_p_set_varnum)
have "extended_ord.punit.is_Groebner_basis (dehomogenize None ` ?G)"
using extended_ord_is_hom_ord ‹finite (insert None (Some ` X))› G_sub
proof (rule extended_ord.isGB_dehomogenize)
from GB_G show "extended_ord.punit.is_Groebner_basis ?G"
by (rule extended_ord.punit.reduced_GB_D1)
next
fix g
assume "g ∈ ?G"
with _ GB_G ideal_G show "homogeneous g"
proof (rule extended_ord.is_reduced_GB_homogeneous)
fix hf
assume "hf ∈ ?F"
then obtain f where "hf = homogenize None f" ..
thus "homogeneous hf" by (simp only: homogeneous_homogenize)
qed
qed
moreover note p_in_ideal
moreover from ‹p ≠ 0› have "extend_indets p ≠ 0" by simp
ultimately obtain g where g_in: "g ∈ dehomogenize None ` ?G" and "g ≠ 0"
and adds: "extended_ord.lpp g adds extended_ord.lpp (extend_indets p)"
by (rule extended_ord.punit.GB_adds_lt[simplified])
have "None ∉ indets g"
proof
assume "None ∈ indets g"
moreover from g_in obtain g0 where "g = dehomogenize None g0" ..
ultimately show False using indets_dehomogenize[of None g0] by blast
qed
show "∃g∈restrict_indets ` ?G. g ≠ 0 ∧ lpp g adds lpp p"
proof (intro bexI conjI notI)
have "lpp (restrict_indets g) = restrict_indets_pp (extended_ord.lpp g)"
by (rule sym, intro extended_ord_lp ‹None ∉ indets g›)
also from adds have "… adds restrict_indets_pp (extended_ord.lpp (extend_indets p))"
by (simp add: adds_poly_mapping le_fun_def lookup_restrict_indets_pp)
also have "… = lpp (restrict_indets (extend_indets p))"
proof (intro extended_ord_lp notI)
assume "None ∈ indets (extend_indets p)"
thus False by (simp add: indets_extend_indets)
qed
also have "… = lpp p" by simp
finally show "lpp (restrict_indets g) adds lpp p" .
next
from g_in have "restrict_indets g ∈ restrict_indets ` dehomogenize None ` ?G" by (rule imageI)
also have "… = restrict_indets ` ?G" by (simp only: image_comp restrict_indets_comp_dehomogenize)
finally show "restrict_indets g ∈ restrict_indets ` ?G" .
next
assume "restrict_indets g = 0"
with ‹None ∉ indets g› extend_restrict_indets have "g = 0" by fastforce
with ‹g ≠ 0› show False ..
qed
qed (fact assms(1))
from ideal_G show ?thesis2 by (rule ideal_restrict_indets)
qed
end
end